build-image:

build-server-image:

deploy-image: build-image

build-client-image:
	docker build -t aftok/aftok-client:latest -f ./client/Dockerfile .
build-images: build-server-image build-client-image
deploy-images: build-server-image build-client-image

	docker tag aftok/aftok-client:latest aftok/aftok-client:$(VERSION)
	docker push docker.io/aftok/aftok-client:latest
	docker push docker.io/aftok/aftok-client:$(VERSION)

               , Aftok.Snaplet.Json

    , unordered-containers

FROM       ubuntu:focal
MAINTAINER Kris Nuttycombe <kris@aftok.com>
ENV LANG            C.UTF-8
ENV TZ              America/Denver
RUN ln -snf /usr/share/zoneinfo/$TZ /etc/localtime && echo $TZ > /etc/timezone
# Install build tools & library dependencies
RUN apt-get update && \
    apt-get install -y --no-install-recommends \
    libtinfo5 nodejs npm netbase
RUN apt-get install -y --no-install-recommends ca-certificates
RUN update-ca-certificates
RUN mkdir -p /opt/aftok/client
WORKDIR /opt/aftok/client
ADD ./client/package.json /opt/aftok/client/package.json
RUN npm install
ENV PATH="./node_modules/.bin:${PATH}"
# Add static assets
ADD ./aftok.com/src/assets /opt/aftok/aftok.com/src/assets
ADD ./client/dev /opt/aftok/client/dev
RUN mkdir -p /opt/aftok/client/prod && \
    ln -s /opt/aftok/aftok.com/src/assets /opt/aftok/client/prod/assets
# Add purescript build config & sources
ADD ./client/spago.dhall /opt/aftok/client/spago.dhall
ADD ./client/packages.dhall /opt/aftok/client/packages.dhall
ADD ./client/src /opt/aftok/client/src
RUN npm run build-prod
# Add dist-volume directory for use with docker-compose sharing
# of client executables via volumes.
ADD ./docker/aftok-client-cp.sh /opt/aftok/
RUN chmod 700 /opt/aftok/aftok-client-cp.sh
RUN mkdir /opt/aftok/client/dist-volume

import Data.Argonaut.Core (Json)

import Type.Proxy (Proxy(..))

import Foreign.Object (Object)
-- import Type.Proxy (Proxy(..))

import Aftok.Types (APIError, JsonCompose, decompose, parseDatedResponse)

-- import Aftok.Types (APIError, JsonCompose, decompose, parseDatedResponse)
import Aftok.Types (APIError, decompose, parseDatedResponse)

data Event' i
  = StartEvent i
  | StopEvent i

data Event t
  = StartEvent t
  | StopEvent t

type Event = Event' Instant

eventTime :: forall i. Event i -> i
eventTime = case _ of
  StartEvent t -> t
  StopEvent t  -> t

derive instance eventFunctor :: Functor Event'

instance showEvent :: (Show i) => Show (Event i) where
  show = case _ of
    StartEvent t -> "Start " <> show t
    StopEvent t -> "Stop " <> show t

instance eventFoldable :: Foldable Event' where

derive instance eventFunctor :: Functor Event
instance eventFoldable :: Foldable Event where

instance eventTraversable :: Traversable Event' where

instance eventTraversable :: Traversable Event where

    StartEvent a -> StartEvent <$> f a 
    StopEvent a -> StopEvent <$> f a 

    StartEvent a -> StartEvent <$> f a
    StopEvent a  -> StopEvent  <$> f a

instance decodeJsonEvent :: DecodeJson (Event' String) where

parseEventFields :: Object Json -> Either String (Event String)
parseEventFields obj = do
  ev <- obj .: "event"
  start' <- traverse (_ .: "eventTime") =<< ev .:? "start"
  stop' <-  traverse (_ .: "eventTime") =<< ev .:? "stop"
  note "Only 'stop' and 'start' events are supported." $
    (StartEvent <$> start') <|>
    (StopEvent  <$> stop')
instance eventDecodeJSON :: DecodeJson (Event String) where
  decodeJson = parseEventFields <=< decodeJson
newtype KeyedEvent i = KeyedEvent
  { eventId :: String
  , event :: Event i
  }
keyedEvent :: forall i. String -> Event i -> KeyedEvent i
keyedEvent eid ev = KeyedEvent { eventId: eid, event: ev }
eventId :: forall i. KeyedEvent i -> String
eventId (KeyedEvent xs) = xs.eventId
event :: forall i. KeyedEvent i -> Event i
event (KeyedEvent xs) = xs.event
derive instance keyedEventFunctor :: Functor KeyedEvent
instance keyedEventFoldable :: Foldable KeyedEvent where
  foldr f b = foldr f b <<< event
  foldl f b = foldl f b <<< event
  foldMap = foldMapDefaultR
instance keyedEventTraversable :: Traversable KeyedEvent where
  traverse f (KeyedEvent xs) = (\ev -> KeyedEvent { eventId: xs.eventId, event: ev }) <$> traverse f xs.event
  sequence = traverse identity
instance keyedEventDecodeJson :: DecodeJson (KeyedEvent String) where

    event <- obj .: "event"
    start' <- traverse (_ .: "eventTime") =<< event .:? "start"
    stop' <-  traverse (_ .: "eventTime") =<< event .:? "stop"
    note "Only 'stop' and 'start' events are supported." $ (StartEvent <$> start') <|> (StopEvent <$> stop')

    keyedEvent <$> obj .: "eventId" <*> parseEventFields obj

newtype Interval' i = Interval

newtype Interval i = Interval

derive instance intervalEq :: (Eq i) => Eq (Interval' i)
derive instance intervalNewtype :: Newtype (Interval' i) _

derive instance intervalEq :: (Eq i) => Eq (Interval i)
derive instance intervalNewtype :: Newtype (Interval i) _

instance showInterval :: Show i => Show (Interval' i) where

instance showInterval :: Show i => Show (Interval i) where

type Interval = Interval' Instant

type TimeInterval = Interval Instant

derive instance intervalFunctor :: Functor Interval'

derive instance intervalFunctor :: Functor Interval

instance intervalFoldable :: Foldable Interval' where
  foldr f b (Interval i) = f i.start (f i.end b) 
  foldl f b (Interval i) = f (f b i.start) i.end 

instance intervalFoldable :: Foldable Interval where
  foldr f b (Interval i) = f i.start (f i.end b)
  foldl f b (Interval i) = f (f b i.start) i.end

instance intervalTraversable :: Traversable Interval' where
  traverse f (Interval i) = interval <$> f i.start <*> f i.end 

instance intervalTraversable :: Traversable Interval where
  traverse f (Interval i) = interval <$> f i.start <*> f i.end

instance decodeJsonInterval :: DecodeJson (Interval' String) where

instance intervalDecodeJSON :: DecodeJson i => DecodeJson (Interval i) where

interval :: forall i. i -> i -> Interval' i

interval :: forall i. i -> i -> Interval i

start :: forall i. Interval' i -> i

start :: forall i. Interval i -> i

end :: forall i. Interval' i -> i

end :: forall i. Interval i -> i

  | During (Interval' t)

  | During (Interval t)

apiLogStart :: ProjectId -> Aff (Either TimelineError Instant)

apiLogStart :: ProjectId -> Aff (Either TimelineError (KeyedEvent Instant))

    event <- withExceptT LogFailure $ parseDatedResponse response
    case event of 
      StartEvent t -> pure t
      StopEvent  _ -> throwError <<< Unexpected $ "Expected start event, got stop."

    kev <- withExceptT LogFailure $ parseDatedResponse response
    case event kev of
      StartEvent _ -> pure kev
      StopEvent _  -> throwError <<< Unexpected $ "Expected start event, got stop."

apiLogEnd :: ProjectId -> Aff (Either TimelineError Instant)

apiLogEnd :: ProjectId -> Aff (Either TimelineError (KeyedEvent Instant))

    event <- withExceptT LogFailure $ parseDatedResponse response
    case event of

    kev <- withExceptT LogFailure $ parseDatedResponse response
    case event kev of

      StopEvent  t -> pure t

      StopEvent _  -> pure kev

  { workIndex :: Array ({ intervals :: Array a }) 

  { workIndex :: Array ({ intervals :: Array a })

  traverse f (ListIntervalsResponse r) = 

  traverse f (ListIntervalsResponse r) =

_ListIntervalsResponse :: Proxy (JsonCompose ListIntervalsResponse Interval' String)
_ListIntervalsResponse = Proxy

apiListIntervals :: ProjectId -> TimeSpan -> Aff (Either TimelineError (Array Interval))

apiListIntervals :: ProjectId -> TimeSpan -> Aff (Either TimelineError (Array (Interval (KeyedEvent Instant))))

  liftEffect 
    <<< runExceptT 

  liftEffect
    <<< runExceptT

    <<< map decompose
    <<< withExceptT LogFailure 

    <<< map (map decompose <<< decompose)
    <<< withExceptT LogFailure

apiLatestEvent :: ProjectId -> Aff (Either TimelineError (Maybe Event))

apiLatestEvent :: ProjectId -> Aff (Either TimelineError (Maybe (KeyedEvent Instant)))

  liftEffect 
    <<< runExceptT 

  liftEffect
    <<< runExceptT

    <<< withExceptT LogFailure 

    <<< withExceptT LogFailure

import Data.Array (reverse)
import Data.Date as D

import Data.Array (reverse, cons)

import Data.Time.Duration (Milliseconds(..), Days(..))

import Data.Time.Duration (Milliseconds(..), Hours(..), Days(..))

import Aftok.Api.Timeline (TimelineError, Interval'(..), Interval, TimeSpan, start, end, interval)

import Aftok.Api.Timeline 
  ( TimelineError, 
    Event(..),
    Interval(..), 
    TimeInterval, 
    KeyedEvent,
    TimeSpan, 
    start, end, interval,
    event, eventTime, keyedEvent
    )

  { bounds  :: Interval

  { bounds  :: TimeInterval

data TimelineEvent
  = LoggedEvent (KeyedEvent Instant)
  | PhantomEvent Instant
instance showTimelineEvent :: Show TimelineEvent where
  show = case _ of
    LoggedEvent kev -> "Real event at " <> show (event kev)
    PhantomEvent i -> "Phantom at " <> show i
tlEventTime :: TimelineEvent -> Instant
tlEventTime = case _ of
  LoggedEvent kev -> eventTime <<< event $ kev
  PhantomEvent i -> i

  { dayBounds :: Interval
  , loggedIntervals :: Array Interval

  { dayBounds :: TimeInterval
  , loggedIntervals :: Array (Interval TimelineEvent)

  , active  :: Maybe Interval

  , active  :: Maybe (Interval TimelineEvent)

  , logStart :: ProjectId -> m (Either TimelineError Instant)
  , logEnd :: ProjectId -> m (Either TimelineError Instant)
  , listIntervals :: ProjectId -> TimeSpan -> m (Either TimelineError (Array Interval))
  , getLatestEvent :: ProjectId -> m (Either TimelineError (Maybe TL.Event))

  , logStart :: ProjectId -> m (Either TimelineError (KeyedEvent Instant))
  , logEnd :: ProjectId -> m (Either TimelineError (KeyedEvent Instant))
  , listIntervals :: ProjectId -> TimeSpan -> m (Either TimelineError (Array (Interval (KeyedEvent Instant))))
  , getLatestEvent :: ProjectId -> m (Either TimelineError (Maybe (KeyedEvent Instant)))

                  --(system.log $ "Got " <> show (length ivals :: Int) <> " intervals for project " <> pidStr (unwrap p).projectId) *>
                  pure ivals

                  pure $ map (map LoggedEvent) ivals

                let activeInterval :: TL.Event -> m (Maybe Interval)
                    activeInterval ev = case ev of

                let activeInterval :: TL.KeyedEvent Instant -> m (Maybe (Interval TimelineEvent))
                    activeInterval ev = case event ev of

                        (Just <<< interval i <$> system.now)

                        (Just <<< interval (LoggedEvent ev) <<< PhantomEvent <$> system.now)

  -> Interval 
  -> Array Interval

  -> TimeInterval 
  -> Array (Interval TimelineEvent)

  .  Interval
  -> Interval

  .  TimeInterval
  -> Interval TimelineEvent

      ileft = ilen limits.start i.start 
      iwidth = ilen i.start i.end

      ileft = ilen limits.start (tlEventTime i.start)
      iwidth = ilen (tlEventTime i.start) (tlEventTime i.end)

  put $ toPct (ilen limits.start i.end)

  put $ toPct (ilen limits.start (tlEventTime i.end))

updateStart :: Instant -> TimelineState -> TimelineState
updateStart t s = 
  s { active = s.active <|> Just (TL.interval t t) }

updateStart :: KeyedEvent Instant -> TimelineState -> TimelineState
updateStart ev s = 
  s { active = s.active <|> Just (TL.interval (LoggedEvent ev) (PhantomEvent <<< eventTime <<< event $ ev)) }

  -> Instant 

  -> KeyedEvent Instant 

updateStop system t st = do
  newHistory <- join <$> traverse (\i -> runMaybeT $ toHistory system [TL.interval (start i) t]) st.active

updateStop system ev st = do
  let updateHistory i = runMaybeT $ toHistory system [TL.interval (start i) (LoggedEvent ev)]
  newHistory <- join <$> traverse updateHistory st.active

  s { active = map (\(Interval i) -> TL.interval i.start t) s.active

  s { active = map (\i -> TL.interval (start i) (PhantomEvent t)) s.active

  , logStart: \_ -> Right <$> liftEffect now
  , logEnd:  \_ -> Right <$> liftEffect now

  , logStart: \_ -> Right <<< keyedEvent "" <<< StartEvent <$> liftEffect now
  , logEnd:   \_ -> Right <<< keyedEvent "" <<< StopEvent <$> liftEffect now

utcDayBounds :: Instant -> Interval

utcDayBounds :: Instant -> TimeInterval 

  -> MaybeT m (Tuple Date Interval)

  -> MaybeT m (Tuple Date TimeInterval)

  end <- MaybeT <<< pure $ fromDateTime <$> DT.adjust (Days 1.0) (toDateTime start)

  nextNoon <- MaybeT <<< pure $  
    fromDateTime <$> (
      DT.adjust (Hours 12.0) <=< DT.adjust (Days 1.0) $
      (toDateTime start)
    )
  Tuple _ end <- MaybeT $ system.dateFFI.midnightLocal nextNoon

incrementDayBounds :: Tuple Date Interval -> Maybe (Tuple Date Interval)
incrementDayBounds (Tuple d i) =
  let nextEnd = fromDateTime <$> (DT.adjust (Days 1.0) $ toDateTime (end i))
   in Tuple <$> D.adjust (Days 1.0) d
            <*> (interval (end i) <$> nextEnd)

  -> Interval 

  -> Interval TimelineEvent 

  --lift <<< system.log $ "Splitting interval " <> show i
  dayBounds@(Tuple date bounds) <- localDayBounds system (start i)
  split <- if end i < (end bounds)
     then do
       pure [Tuple date { dayBounds: bounds, loggedIntervals: [i] }]
     else do
       let firstFragment = [ Tuple date { dayBounds: bounds
                           , loggedIntervals: [interval (start i) (end bounds)] 
                           } ]
       append firstFragment <$> splitInterval system (interval (end bounds) (end i))

  lift <<< system.log $ "Splitting interval " <> show i
  -- day bounds are based on the start event.
  Tuple date bounds <- localDayBounds system (tlEventTime $ start i)
  lift <<< system.log $ "Splitting on day bounds: " <> show (start bounds) <> " to " <> show (end bounds)
  split <- if tlEventTime (end i) < end bounds
    then do
      lift <<< system.log $ "Split complete"
      pure [Tuple date { dayBounds: bounds, loggedIntervals: [i] }]
    else do
      let splitEvent = PhantomEvent (end bounds)
          currInterval = Tuple date { dayBounds: bounds, loggedIntervals: [interval (start i) splitEvent] }
          nextInterval = interval splitEvent (end i)
      lift <<< system.log $ "Split required; first fragment: " <> show currInterval <> "; next interval: " <> show nextInterval
      cons currInterval <$> splitInterval system nextInterval

  -> Array Interval 

  -> Array (Interval TimelineEvent)

  splitIntervals <- join <$> traverse (splitInterval system) xs
  pure $ M.fromFoldableWith unionDayIntervals splitIntervals

  splits <- join <$> traverse (splitInterval system) xs
  pure $ M.fromFoldableWith unionDayIntervals splits

#!/bin/bash
echo "Copying client build artifacts to mounted volume..."
cp -r /opt/aftok/client/dist/* /opt/aftok/client/dist-volume
echo "Client copy complete. The container will now shut down."

      - zcashd

  aftok-client:
    image: aftok/aftok-client:latest
    container_name: aftok-client
    entrypoint: /opt/aftok/aftok-client-cp.sh
    volumes:
      - type: volume
        source: v_aftok-client
        target: /opt/aftok/client/dist-volume

        source: ./client/dist/

        source: ./client/dist

        # - type: volume
        #   source: v_aftok-client
        #   target: /opt/static/app
        #   read_only: true

  zcashd:
    image: electriccoinco/zcashd:v4.0.0
    container_name: aftok-zcashd
    expose:
      - "18232"
    ports:
      - "18233:18233"
    volumes:
      - type: bind
        source: ./local/zcashd/zcash-data
        target: /srv/zcashd/.zcash
      - type: bind
        source: ./local/zcashd/zcash-params
        target: /srv/zcashd/.zcash-params
        read_only: true
    networks:
      - back-tier

#  zcashd:
#    image: electriccoinco/zcashd:v4.0.0
#    container_name: aftok-zcashd
#    expose:
#      - "18232"
#    ports:
#      - "18233:18233"
#    volumes:
#      - type: bind
#        source: ./local/zcashd/zcash-data
#        target: /srv/zcashd/.zcash
#      - type: bind
#        source: ./local/zcashd/zcash-params
#        target: /srv/zcashd/.zcash-params
#        read_only: true
#    networks:
#      - back-tier

  v_aftok-client:

import qualified Aftok.Billing as B

    KeyedLogEntry,

    KeyedLogEntry(KeyedLogEntry),

    logEntry,
    workId,

    pexec,

    ptransact,

    createSubscriptionJSON,

    idValue,
    obj,
    v1,

import Aftok.TimeLog

import Aftok.TimeLog (
  WorkIndex,
  LogEntry(LogEntry),
  LogEvent(..),
  EventId(..),
  EventAmendment(..),
  AmendmentId(..),
  eventMeta,
  _ModTime,
  _EventId,
  _AmendmentId,
  creditTo,
  eventTime,
  event,
  workIndex,
  eventName,
  nameEvent,
  )

import Control.Lens ((^.), _Just, preview)

import Control.Lens ((^.), _Just, preview, set, view)

  ( Value,

  ( (.=),
    Value,

  (,,) <$> idParser ProjectId <*> idParser UserId <*> logEntryParser

  KeyedLogEntry <$> idParser EventId <*> logEntryParser

createSubscriptionJSON :: UserId -> B.BillableId -> Day -> Value
createSubscriptionJSON uid bid d =
  v1 $
    obj
      [ "user_id" .= idValue _UserId uid,
        "billable_id" .= idValue B._BillableId bid,
        "start_date" .= showGregorian d
      ]

findEvent :: EventId -> DBM (Maybe KeyedLogEntry)

findEvent :: EventId -> DBM (Maybe (ProjectId, UserId, KeyedLogEntry))

      keyedLogEntryParser
      [sql| SELECT project_id, user_id,

      ((,,) <$> idParser ProjectId <*> idParser UserId <*> keyedLogEntryParser)
      [sql| SELECT project_id, user_id, id,

                 event_type, event_time, event_metadata FROM work_events
          WHERE id = ? |]

                 event_type, event_time, event_metadata
            FROM work_events
            WHERE id = ?
            AND replacement_id IS NULL
            |]

findEvents :: ProjectId -> UserId -> RangeQuery -> Limit -> DBM [LogEntry]

findEvents :: ProjectId -> UserId -> RangeQuery -> Limit -> DBM [KeyedLogEntry]

        logEntryParser
        [sql| SELECT credit_to_type,
                   credit_to_account, credit_to_user_id, credit_to_project_id,
                   event_type, event_time,
                   event_metadata
            FROM work_events
            WHERE project_id = ? AND user_id = ? AND event_time <= ?
            ORDER BY event_time DESC
            LIMIT ?
            |]

        keyedLogEntryParser
        [sql| SELECT id, credit_to_type,
                     credit_to_account, credit_to_user_id, credit_to_project_id,
                     event_type, event_time,
                     event_metadata
              FROM work_events
              WHERE project_id = ? AND user_id = ? AND event_time <= ?
              AND replacement_id IS NULL
              ORDER BY event_time DESC
              LIMIT ?
              |]

        logEntryParser
        [sql| SELECT credit_to_type,
                   credit_to_account, credit_to_user_id, credit_to_project_id,
                   event_type, event_time, event_metadata
            FROM work_events
            WHERE project_id = ? AND user_id = ?
            AND event_time >= ? AND event_time <= ?
            ORDER BY event_time DESC
            LIMIT ?
            |]

        keyedLogEntryParser
        [sql| SELECT id, credit_to_type,
                     credit_to_account, credit_to_user_id, credit_to_project_id,
                     event_type, event_time, event_metadata
              FROM work_events
              WHERE project_id = ? AND user_id = ?
              AND replacement_id IS NULL
              AND event_time >= ? AND event_time <= ?
              ORDER BY event_time DESC
              LIMIT ?
              |]

        logEntryParser
        [sql| SELECT credit_to_type,
                   credit_to_account, credit_to_user_id, credit_to_project_id,
                   event_type, event_time, event_metadata
            FROM work_events
            WHERE project_id = ? AND user_id = ? AND event_time >= ?
            ORDER BY event_time DESC
            LIMIT ?
            |]

        keyedLogEntryParser
        [sql| SELECT id, credit_to_type,
                     credit_to_account, credit_to_user_id, credit_to_project_id,
                     event_type, event_time, event_metadata
              FROM work_events
              WHERE project_id = ? AND user_id = ? AND event_time >= ?
              AND replacement_id IS NULL
              ORDER BY event_time DESC
              LIMIT ?
              |]

        logEntryParser
        [sql| SELECT credit_to_type,
                   credit_to_account, credit_to_user_id, credit_to_project_id,
                   event_type, event_time, event_metadata
            FROM work_events
            WHERE project_id = ? AND user_id = ?
            ORDER BY event_time DESC
            LIMIT ?
            |]

        keyedLogEntryParser
        [sql| SELECT id, credit_to_type,
                     credit_to_account, credit_to_user_id, credit_to_project_id,
                     event_type, event_time, event_metadata
              FROM work_events
              WHERE project_id = ? AND user_id = ?
              AND replacement_id IS NULL
              ORDER BY event_time DESC
              LIMIT ?
              |]

amendEvent :: EventId -> EventAmendment -> DBM AmendmentId
amendEvent (EventId eid) = \case
  (TimeChange mt t) ->
    pinsert
      AmendmentId
      [sql| INSERT INTO event_time_amendments
              (event_id, amended_at, event_time)
              VALUES (?, ?, ?) RETURNING id |]
      (eid, fromThyme $ mt ^. _ModTime, fromThyme t)
  (CreditToChange mt c@(CreditToAccount acctId)) ->
    pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments
            (event_id, amended_at, credit_to_type, credit_to_account)
            VALUES (?, ?, ?, ?) RETURNING id |]
      (eid, fromThyme $ mt ^. _ModTime, creditToName c, acctId ^. _AccountId)
  (CreditToChange mt c@(CreditToProject pid)) ->
    pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments
              (event_id, amended_at, credit_to_type, credit_to_project_id)
              VALUES (?, ?, ?, ?) RETURNING id |]
      (eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId)
  (CreditToChange mt c@(CreditToUser uid)) ->
    pinsert
      AmendmentId
      [sql| INSERT INTO event_credit_to_amendments
              (event_id, amended_at, credit_to_type, credit_to_user_id)
              VALUES (?, ?, ?, ?) RETURNING id |]
      (eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId)
  (MetadataChange mt v) ->
    pinsert
      AmendmentId
      [sql| INSERT INTO event_metadata_amendments
              (event_id, amended_at, event_metadata)
              VALUES (?, ?, ?) RETURNING id |]
      (eid, fromThyme $ mt ^. _ModTime, v)

readWorkIndex :: ProjectId -> DBM WorkIndex

readWorkIndex :: ProjectId -> DBM (WorkIndex KeyedLogEntry)

      logEntryParser
      [sql| SELECT credit_to_type,

      keyedLogEntryParser
      [sql| SELECT id, credit_to_type,

  pure $ workIndex logEntries

  pure $ workIndex (view logEntry) logEntries
amendEvent :: ProjectId -> UserId -> KeyedLogEntry -> EventAmendment -> DBM (EventId, AmendmentId)
amendEvent pid uid kle amendment = ptransact $ do
  (amendId, replacement, amend_t :: Text) <- amend
  newEventId <- createEvent pid uid (replacement ^. logEntry)
  void $
    pexec
      [sql| UPDATE work_events
          SET replacement_id = ?, amended_by_id = ?, amended_by_type = ?
          WHERE id = ? |]
      (newEventId ^. _EventId, amendId ^. _AmendmentId, amend_t, kle ^. workId . _EventId)
  pure (newEventId, amendId)
  where
    amend = case amendment of
      (TimeChange mt t) -> do
        aid <-
          pinsert
            AmendmentId
            [sql| INSERT INTO event_time_amendments
                  (work_event_id, amended_at, event_time)
                  VALUES (?, ?, ?) RETURNING id |]
            (kle ^. workId . _EventId, fromThyme $ mt ^. _ModTime, fromThyme t)
        pure (aid, set (logEntry . event . eventTime) t kle, "amend_event_time")
      (CreditToChange mt c@(CreditToAccount acctId)) -> do
        aid <-
          pinsert
            AmendmentId
            [sql| INSERT INTO event_credit_to_amendments
                  (work_event_id, amended_at, credit_to_type, credit_to_account)
                  VALUES (?, ?, ?, ?) RETURNING id |]
            (kle ^. workId . _EventId, fromThyme $ mt ^. _ModTime, creditToName c, acctId ^. _AccountId)
        pure (aid, set (logEntry . creditTo) c kle, "amend_credit_to")
      (CreditToChange mt c@(CreditToProject cpid)) -> do
        aid <-
          pinsert
            AmendmentId
            [sql| INSERT INTO event_credit_to_amendments
                  (work_event_id, amended_at, credit_to_type, credit_to_project_id)
                  VALUES (?, ?, ?, ?) RETURNING id |]
            (kle ^. workId . _EventId, fromThyme $ mt ^. _ModTime, creditToName c, cpid ^. _ProjectId)
        pure (aid, set (logEntry . creditTo) c kle, "amend_credit_to")
      (CreditToChange mt c@(CreditToUser cuid)) -> do
        aid <-
          pinsert
            AmendmentId
            [sql| INSERT INTO event_credit_to_amendments
                  (work_event_id, amended_at, credit_to_type, credit_to_user_id)
                  VALUES (?, ?, ?, ?) RETURNING id |]
            (kle ^. workId . _EventId, fromThyme $ mt ^. _ModTime, creditToName c, cuid ^. _UserId)
        pure (aid, set (logEntry . creditTo) c kle, "amend_credit_to")
      (MetadataChange mt v) -> do
        aid <-
          pinsert
            AmendmentId
            [sql| INSERT INTO event_metadata_amendments
                  (work_event_id, amended_at, event_metadata)
                  VALUES (?, ?, ?) RETURNING id |]
            (kle ^. workId . _EventId, fromThyme $ mt ^. _ModTime, v)
        pure (aid, set (logEntry . eventMeta) (Just v) kle, "amend_metadata")

    (AmendEvent eid amendment) -> Q.amendEvent eid amendment

    (AmendEvent pid uid kle amendment) -> Q.amendEvent pid uid kle amendment

import qualified Aftok.TimeLog as TL

    HasLogEntry,

    makeClassy,

data KeyedLogEntry = KeyedLogEntry {
    _workId :: !EventId,
    _logEntry :: !LogEntry
  }
makeClassy ''KeyedLogEntry

type KeyedLogEntry = (ProjectId, UserId, LogEntry)

instance HasLogEntry KeyedLogEntry where
  logEntry = Aftok.Database.logEntry

  AmendEvent :: EventId -> EventAmendment -> DBOp AmendmentId
  FindEvent :: EventId -> DBOp (Maybe KeyedLogEntry)
  FindEvents :: ProjectId -> UserId -> RangeQuery -> Limit -> DBOp [LogEntry]
  ReadWorkIndex :: ProjectId -> DBOp WorkIndex

  AmendEvent :: ProjectId -> UserId -> KeyedLogEntry -> EventAmendment -> DBOp (EventId, AmendmentId)
  FindEvent :: EventId -> DBOp (Maybe (ProjectId, UserId, KeyedLogEntry))
  FindEvents :: ProjectId -> UserId -> RangeQuery -> Limit -> DBOp [KeyedLogEntry]
  ReadWorkIndex :: ProjectId -> DBOp (WorkIndex KeyedLogEntry)

  (MonadDB m) => UserId -> EventId -> EventAmendment -> m AmendmentId

  (MonadDB m) => UserId -> EventId -> EventAmendment -> m (EventId, AmendmentId)

  ev <- findEvent eid
  let act = AmendEvent eid a
      forbidden = raiseOpForbidden uid UserNotEventLogger act
      missing = raiseSubjectNotFound act
  maybe
    missing
    (\(_, uid', _) -> if uid' == uid then liftdb act else forbidden)
    ev

  evMay <- findEvent eid
  maybe missing saveAmendment evMay
  where
    missing = raiseSubjectNotFound (FindEvent eid)
    saveAmendment (pid, uid', le) =
      let act = AmendEvent pid uid le a
      in if uid' == uid
        then liftdb act
        else raiseOpForbidden uid UserNotEventLogger act

findEvent :: (MonadDB m) => EventId -> m (Maybe KeyedLogEntry)

findEvent :: (MonadDB m) => EventId -> m (Maybe (ProjectId, UserId, KeyedLogEntry))

  m [LogEntry]

  m [KeyedLogEntry]

readWorkIndex :: (MonadDB m) => ProjectId -> UserId -> m WorkIndex

readWorkIndex :: (MonadDB m) => ProjectId -> UserId -> m (WorkIndex KeyedLogEntry)

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}

data Interval

data Interval t

      { _start :: C.UTCTime,
        _end :: C.UTCTime

      { _start :: t,
        _end :: t

  deriving (Show, Eq, Ord)

  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

interval :: C.UTCTime -> C.UTCTime -> Interval

interval :: Ord t => t -> t -> Interval t

containsInclusive :: C.UTCTime -> Interval -> Bool

containsInclusive :: Ord t => t -> Interval t -> Bool

ilen :: Interval -> C.NominalDiffTime

ilen :: Interval C.UTCTime -> C.NominalDiffTime

intervalJSON :: Interval -> Value
intervalJSON ival = object ["start" .= (ival ^. start), "end" .= (ival ^. end)]

intervalJSON :: (t -> Value) -> Interval t -> Value
intervalJSON f ival = object ["start" .= f (ival ^. start), "end" .= f (ival ^. end)]

parseIntervalJSON :: Value -> Parser Interval

parseIntervalJSON :: (Ord t, FromJSON t) => Value -> Parser (Interval t)

import qualified Aftok.Auction as A

import Aftok.Interval
import Aftok.Payments.Types
  ( PaymentId,
    _PaymentId,
  )
import qualified Aftok.Project as P

import qualified Control.Lens as L

import Data.List.NonEmpty as L
import Data.Map.Strict as MS

import Data.Thyme.Calendar (showGregorian)

import Data.Thyme.Time (Day)

version :: MonadFail m => ByteString -> m Version
version = fromEitherM fail . PC.parseOnly versionParser

parseVersion :: MonadFail m => ByteString -> m Version
parseVersion = fromEitherM fail . PC.parseOnly versionParser

  ver <- version $ C.pack s

  ver <- parseVersion $ C.pack s

idJSON :: forall a. Text -> Getter a UUID -> a -> Value
idJSON t l a = v1 $ obj [t .= idValue l a]
qdbJSON :: Text -> Getter a UUID -> Getter a Value -> a -> Value
qdbJSON name _id _value x =
  v1 $ obj [(name <> "Id") .= idValue _id x, name .= (x ^. _value)]
projectIdJSON :: ProjectId -> Value
projectIdJSON = idJSON "projectId" _ProjectId
projectJSON :: P.Project -> Value
projectJSON p =
  v1 $
    obj
      [ "projectName" .= (p ^. P.projectName),
        "inceptionDate" .= (p ^. P.inceptionDate),
        "initiator" .= (p ^. P.initiator . _UserId)
      ]
qdbProjectJSON :: (ProjectId, P.Project) -> Value
qdbProjectJSON = qdbJSON "project" (_1 . _ProjectId) (_2 . L.to projectJSON)
auctionIdJSON :: A.AuctionId -> Value
auctionIdJSON = idJSON "auctionId" A._AuctionId
auctionJSON :: A.Auction Amount -> Value
auctionJSON x =
  v1 $
    obj
      [ "projectId" .= idValue (A.projectId . _ProjectId) x,
        "initiator" .= idValue (A.initiator . _UserId) x,
        "name" .= (x ^. A.name),
        "description" .= (x ^. A.description),
        "raiseAmount" .= (x ^. (A.raiseAmount . to amountJSON)),
        "auctionStart" .= (x ^. A.auctionStart),
        "auctionEnd" .= (x ^. A.auctionEnd)
      ]

bidIdJSON :: A.BidId -> Value
bidIdJSON pid = v1 $ obj ["bidId" .= (pid ^. A._BidId)]

identifiedJSON :: Text -> Getter a UUID -> Getter a Value -> a -> Value
identifiedJSON name _id _value x =
  object [(name <> "Id") .= idValue _id x, name .= (x ^. _value)]

  v2 $ obj ["creditToAccount" .= idValue _AccountId accountId]

  object ["creditToAccount" .= idValue _AccountId accountId]

  v2 $ obj ["creditToUser" .= idValue _UserId uid]

  object ["creditToUser" .= idValue _UserId uid]

  v2 $ obj ["creditToProject" .= projectIdJSON pid]
parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion "CreditTo" $ \case
  (Version 2 0) -> parseCreditToV2
  ver -> badVersion "EventAmendment" ver

  object ["creditToProject" .= idValue _ProjectId pid]

-- Payouts
--
payoutsJSON :: FractionalPayouts -> Value
payoutsJSON (Payouts m) =
  v2 $
    let payoutsRec :: (CreditTo, Rational) -> Value
        payoutsRec (c, r) =
          object ["creditTo" .= creditToJSON c, "payoutRatio" .= r, "payoutPercentage" .= (fromRational @Double r * 100)]
     in obj $ ["payouts" .= fmap payoutsRec (MS.assocs m)]
parsePayoutsJSON :: Value -> Parser FractionalPayouts
parsePayoutsJSON = unversion "Payouts" $ p
  where
    p :: Version -> Object -> Parser FractionalPayouts
    p (Version 2 0) val =
      let parsePayoutRecord x =
            (,)
              <$> (parseCreditToV2 =<< (x .: "creditTo"))
              <*> (x .: "payoutRatio")
       in Payouts
            . MS.fromList
            <$> (traverse parsePayoutRecord =<< parseJSON (Object val))
    p ver x = badVersion "Payouts" ver x
--

workIndexJSON :: WorkIndex -> Value
workIndexJSON (WorkIndex widx) =
  v2 $
    obj ["workIndex" .= fmap widxRec (MS.assocs widx)]
  where
    widxRec :: (CreditTo, NonEmpty Interval) -> Value
    widxRec (c, l) =
      object
        [ "creditTo" .= creditToJSON c,
          "intervals" .= (intervalJSON <$> L.toList l)
        ]
eventIdJSON :: EventId -> Value
eventIdJSON = idJSON "eventId" _EventId
logEventJSON' :: LogEvent -> Value
logEventJSON' ev =
  object [eventName ev .= object ["eventTime" .= (ev ^. eventTime)]]
logEntryJSON :: LogEntry -> Value
logEntryJSON le = v2 $ obj (logEntryFields le)
logEntryFields :: LogEntry -> [Pair]
logEntryFields (LogEntry c ev m) =
  [ "creditTo" .= creditToJSON c,
    "event" .= logEventJSON' ev,
    "eventMeta" .= m
  ]
amendmentIdJSON :: AmendmentId -> Value
amendmentIdJSON = idJSON "amendmentId" _AmendmentId

billableIdJSON :: B.BillableId -> Value
billableIdJSON = idJSON "billableId" B._BillableId

  qdbJSON "billable" (_1 . B._BillableId) (_2 . to billableJSON)

  identifiedJSON "billable" (_1 . B._BillableId) (_2 . to billableJSON)

createSubscriptionJSON :: UserId -> B.BillableId -> Day -> Value
createSubscriptionJSON uid bid d =
  v1 $
    obj
      [ "user_id" .= idValue _UserId uid,
        "billable_id" .= idValue B._BillableId bid,
        "start_date" .= showGregorian d
      ]
subscriptionJSON :: B.Subscription -> Value
subscriptionJSON = v1 . obj . subscriptionKV
subscriptionKV :: (KeyValue kv) => B.Subscription -> [kv]
subscriptionKV sub =
  [ "user_id" .= idValue (B.customer . _UserId) sub,
    "billable_id" .= idValue (B.billable . B._BillableId) sub,
    "start_time" .= view B.startTime sub,
    "end_time" .= view B.endTime sub
  ]
subscriptionIdJSON :: B.SubscriptionId -> Value
subscriptionIdJSON = idJSON "subscriptionId" B._SubscriptionId
-- paymentRequestDetailsJSON :: [PaymentRequestDetail Amount] -> Value
-- paymentRequestDetailsJSON r = v1 $ obj ["payment_requests" .= fmap paymentRequestDetailJSON r]
--
-- paymentRequestDetailJSON :: PaymentRequestDetail Amount -> Object
-- paymentRequestDetailJSON r = obj $ concat
--   [ ["payment_request_id" .= view () r]
--   , paymentRequestKV $ view _2 r
--   , subscriptionKV $ view _3 r
--   , billableKV $ view _4 r
--   ]
paymentIdJSON :: PaymentId -> Value
paymentIdJSON = idJSON "paymentId" _PaymentId

parseEventAmendment ::
  ModTime ->
  Value ->
  Parser EventAmendment
parseEventAmendment t = unversion "EventAmendment" $ p
  where
    p (Version 2 0) = parseEventAmendmentV2 t
    p ver = badVersion "EventAmendment" ver
parseEventAmendmentV2 ::
  ModTime ->
  Object ->
  Parser EventAmendment
parseEventAmendmentV2 t o =
  let parseA :: Text -> Parser EventAmendment
      parseA "timeChange" = TimeChange t <$> o .: "eventTime"
      parseA "creditToChange" = CreditToChange t <$> parseCreditToV2 o
      parseA "metadataChange" = MetadataChange t <$> o .: "eventMeta"
      parseA tid =
        fail . T.unpack $ "Amendment type " <> tid <> " not recognized."
   in o .: "amendment" >>= parseA

parseLogEntry uid f = unversion "LogEntry" p

parseLogEntry uid f = withObject "LogEntry" p

    p (Version 2 0) o = do

    p o = do

    p ver o = badVersion "LogEntry" ver o
parseRecurrence :: Object -> Parser B.Recurrence
parseRecurrence o =
  let parseAnnually o' = const (pure B.Annually) <$> O.lookup "annually" o'
      parseMonthly o' = fmap B.Monthly . parseJSON <$> O.lookup "monthly" o'
      parseWeekly o' = fmap B.Weekly . parseJSON <$> O.lookup "weekly" o'
      parseOneTime o' = const (pure B.OneTime) <$> O.lookup "one-time" o'
      notFound =
        fail $ "Value " <> show o <> " does not represent a Recurrence value."
      parseV val =
        parseAnnually val
          <|> parseMonthly val
          <|> parseWeekly val
          <|> parseOneTime val
   in fromMaybe notFound $ parseV o
parseRecurrence' :: Value -> Parser B.Recurrence
parseRecurrence' = \case
  (Object o) -> parseRecurrence o
  val -> fail $ "Value " <> show val <> " is not a JSON object."

{-# LANGUAGE ViewPatterns #-}

    creditTo,
    event,
    eventMeta,

    HasLogEntry (..),

    _StartWork,
    _StopWork,

import Control.Arrow ((&&&))

import Data.Either
  ( Either (..),
    rights,
  )
import Data.Eq
  ( (==),
    Eq,
  )

import Data.Function
  ( ($),
    (.),
    id,
  )
import Data.Functor (fmap)
import Data.Heap as H
import Data.List.NonEmpty as L
import Data.Map.Strict as MS
import Data.Maybe (Maybe (..))
import Data.Ord
  ( Ord (..),
    Ordering (..),
  )
import Data.Ratio (Rational)
import Data.Text (Text)

import qualified Data.Map.Strict as MS

import Data.UUID
import Data.VectorSpace
import Text.Show (Show)
import Prelude
  ( (*),
    (/),
  )

import Data.UUID (UUID)
import Data.VectorSpace ((*^), Sum (..), (^+^), (^-^), getSum, zeroV)
import Prelude hiding (Sum, getSum)

type DepF = C.UTCTime -> Interval -> NDT

type DepF = C.UTCTime -> Interval C.UTCTime -> NDT

makePrisms ''LogEvent

makeLenses ''LogEntry

makeClassy ''LogEntry

newtype EventId = EventId UUID deriving (Show, Eq)

newtype EventId = EventId UUID deriving (Show, Eq, Ord)

newtype AmendmentId = AmendmentId UUID deriving (Show, Eq)

newtype AmendmentId = AmendmentId UUID deriving (Show, Eq, Ord)

newtype WorkIndex = WorkIndex (Map CreditTo (NonEmpty Interval)) deriving (Show, Eq)

newtype WorkIndex t = WorkIndex (Map CreditTo (NonEmpty (Interval t))) deriving (Show, Eq)

workCredit :: (Foldable f) => DepF -> C.UTCTime -> f Interval -> NDT
workCredit df ptime ivals = getSum $ F.foldMap (Sum . df ptime) ivals

workCredit :: (Foldable f, HasLogEntry le) => DepF -> C.UTCTime -> f (Interval le) -> NDT
workCredit df ptime ivals = getSum $ F.foldMap (Sum . df ptime . fmap (view $ event . eventTime)) ivals

payouts :: DepF -> C.UTCTime -> WorkIndex -> FractionalPayouts

payouts :: forall le. (HasLogEntry le) => DepF -> C.UTCTime -> WorkIndex le -> FractionalPayouts

  let addIntervalDiff :: (Foldable f) => NDT -> f Interval -> (NDT, NDT)

  let addIntervalDiff :: (Foldable f) => NDT -> f (Interval le) -> (NDT, NDT)

workIndex :: Foldable f => f LogEntry -> WorkIndex
workIndex logEntries =
  let sortedEntries = F.foldr H.insert H.empty logEntries

workIndex :: (Foldable f, HasLogEntry le, Ord o) => (le -> o) -> f le -> WorkIndex le
workIndex cmp logEntries =
  let sortedEntries = sortWith cmp $ toList logEntries

        [Either LogEvent Interval] ->
        Map CreditTo (NonEmpty Interval) ->
        Map CreditTo (NonEmpty Interval)

        [Either le (Interval le)] ->
        Map CreditTo (NonEmpty (Interval le)) ->
        Map CreditTo (NonEmpty (Interval le))

type RawIndex = Map CreditTo [Either LogEvent Interval]

type RawIndex le = Map CreditTo [Either le (Interval le)]

appendLogEntry :: RawIndex -> LogEntry -> RawIndex
appendLogEntry idx (LogEntry k ev _) =
  let combine :: LogEvent -> LogEvent -> Either LogEvent Interval
      combine (StartWork t) (StopWork t') | t' > t = Right $ Interval t t'
      combine (e1@(StartWork _)) (e2@(StartWork _)) = Left $ max e1 e2 -- ignore redundant starts
      combine (e1@(StopWork _)) (e2@(StopWork _)) = Left $ min e1 e2 -- ignore redundant ends
      combine _ e2 = Left e2
      -- if the interval includes the timestamp of a start event, then allow the extension of the interval
      extension :: Interval -> LogEvent -> Maybe LogEvent
      extension ival (StartWork t)
        | containsInclusive t ival =
          Just $ StartWork (ival ^. start)
      extension _ _ = Nothing

appendLogEntry ::
  forall le.
  HasLogEntry le =>
  RawIndex le ->
  le ->
  RawIndex le
appendLogEntry idx logEvent =
  let k = logEvent ^. logEntry . creditTo

        Just (Right ival : xs) -> case extension ival ev of
          Just e' -> Left e' : xs
          Nothing -> Left ev : Right ival : xs

        Just (Right ival : xs) ->
          case extension (view (event . eventTime) <$> ival) logEvent of
            Just e' -> Left e' : xs
            Nothing -> Left logEvent : Right ival : xs

        Just (Left ev' : xs) -> combine ev' ev : xs
        _ -> [Left ev]

        Just (Left ev' : xs) ->
          combine ev' logEvent : xs
        _ -> [Left logEvent]

  where
    combine :: le -> le -> Either le (Interval le)
    combine e e' = case (e ^. event, e' ^. event) of
      (StartWork t, StopWork t') | t' > t -> Right $ Interval e e' -- complete interval found
      (StartWork t, StartWork t') -> Left $ if t > t' then e else e' -- ignore redundant starts
      (StopWork t, StopWork t') -> Left $ if t <= t' then e else e' -- ignore redundant ends
      _ -> Left e'
    -- if the interval includes the timestamp of a start event, then allow the extension of the interval
    extension :: (Interval C.UTCTime) -> le -> Maybe le
    extension ival newEvent@(view event -> StartWork t)
      | containsInclusive t ival =
        Just newEvent -- replace the end of the interval with the new event
    extension _ _ =
      Nothing

Description: (Describe migration here.)
Created: 2021-01-16 05:04:54.586280477 UTC
Depends: 2017-06-08_04-37-31_event-metadata-ids 2016-10-14_02-49-36_event-amendments
Apply: |
  CREATE TYPE amendment_t AS ENUM ('amend_event_time', 'amend_credit_to', 'amend_metadata');
  ALTER TABLE work_events ADD COLUMN replacement_id uuid REFERENCES work_events(id);
  ALTER TABLE work_events ADD COLUMN amended_by_type amendment_t;
  ALTER TABLE work_events ADD COLUMN amended_by_id uuid;

#!/bin/bash
if [ -f ".env" ]; then
  source .env
fi
if [ -z "${AFTOK_HOST}" ]; then 
  AFTOK_HOST="aftok.com"
fi
if [ -z "${USER}" ]; then 
  read -p "Username: " USER
  echo
fi
read -p "Event ID: " EID
while [ -z "${ATYPE}" ]
do 
  read -p "Amendment Type: " ATYPE
  case $ATYPE in
    # "CREDIT_TO")
    #   AVALUE="creditToChange"
    #   read -p "Raise amount, in Bitcoin satoshis: " AMOUNT
    #   ;;
    "TIME")
      AVALUE="timeChange"
      read -p "Event Timestamp (yyyy-MM-ddTHH:mm:ssZ): " ATIME
      ;;
    *)
      echo "$ATYPE is not a amendment type. Please choose \"TIME\"" # or \"CREDIT_TO\""
      ATYPE=""
      ;;
  esac
done
BODY=$(cat <<END_BODY
{
  "schemaVersion": "2.0",
  "amendment": "timeChange",
  "eventTime": "$ATIME"
}
END_BODY
)
curl --verbose \
  ${ALLOW_INSECURE} \
  --user $USER \
  --header "Content-Type: application/json" \
  --request PUT \
  --data "$BODY" \
  "https://$AFTOK_HOST/api/events/$EID/amend"

#!/bin/bash
if [ -f ".env" ]; then
  source .env
fi
if [ -z "${AFTOK_HOST}" ]; then 
  AFTOK_HOST="aftok.com"
fi
if [ -z "${PID}" ]; then
  read -p "Project UUID: " PID
  echo
fi
if [ -z "${USER}" ]; then 
  read -p "Username: " USER
  echo
fi
read -p "Auction Name: " NAME
read -p "Description: " DESC
while [ -z "${CCY}" ]
do 
  read -p "Currency: " CCY
  case $CCY in
    "BTC")
      CCY="satoshi"
      read -p "Raise amount, in Bitcoin satoshis: " AMOUNT
      ;;
    "ZEC")
      CCY="zatoshi"
      read -p "Raise amount, in Zcash zatoshis: " AMOUNT
      ;;
    *)
      echo "$CCY is not a supported currency. Please choose \"BTC\" or \"ZEC\""
      CCY=""
      ;;
  esac
done
echo
read -p "Auction start date (yyyy-MM-ddThh:mm:ssZ): " START
read -p "Auction end date (yyyy-MM-ddThh:mm:ssZ): " END
BODY=$(cat <<END_BODY
{
  "auction_name": "$NAME", 
  "auction_desc": "$DESC", 
  "raise_amount": {
    "$CCY": $AMOUNT
  },
  "auction_start": "$START",
  "auction_end": "$END"
}
END_BODY
)
curl --verbose \
  ${ALLOW_INSECURE} \
  --user $USER \
  --header "Content-Type: application/json" \
  --data "$BODY" \
  "https://$AFTOK_HOST/api/projects/$PID/auctions"

    auctionJSON,
    bidIdJSON,

  ( Auction (..),

  ( Auction (Auction),

    Bid (..),

    Bid (Bid),

    _BidId,
    auctionEnd,
    auctionStart,
    description,
    initiator,
    name,
    projectId,
    raiseAmount,

import Aftok.Types (UserId)

import Aftok.Types (UserId, _ProjectId, _UserId)

import Control.Lens ((^.), to)

      { name :: Text,
        description :: Maybe Text,
        raiseAmount :: Amount,
        auctionStart :: C.UTCTime,
        auctionEnd :: C.UTCTime

      { acrName :: Text,
        acrDescription :: Maybe Text,
        acrRaiseAmount :: Amount,
        acrAuctionStart :: C.UTCTime,
        acrAuctionEnd :: C.UTCTime

      (name req)
      (description req)
      (raiseAmount $ req)
      (auctionStart req)
      (auctionEnd req)

      (acrName req)
      (acrDescription req)
      (acrRaiseAmount $ req)
      (acrAuctionStart req)
      (acrAuctionEnd req)

auctionJSON :: Auction Amount -> Value
auctionJSON x =
  v1 $
    obj
      [ "projectId" .= idValue (projectId . _ProjectId) x,
        "initiator" .= idValue (initiator . _UserId) x,
        "name" .= (x ^. name),
        "description" .= (x ^. description),
        "raiseAmount" .= (x ^. (raiseAmount . to amountJSON)),
        "auctionStart" .= (x ^. auctionStart),
        "auctionEnd" .= (x ^. auctionEnd)
      ]
bidIdJSON :: BidId -> Value
bidIdJSON pid = v1 $ obj ["bidId" .= (pid ^. _BidId)]

import Aftok.Billing

import Aftok.Billing as B

import qualified Data.HashMap.Strict as O

-- subscriptionJSON :: B.Subscription -> Value
-- subscriptionJSON = v1 . obj . subscriptionKV
--
-- subscriptionKV :: (KeyValue kv) => B.Subscription -> [kv]
-- subscriptionKV sub =
--   [ "user_id" .= idValue (B.customer . _UserId) sub,
--     "billable_id" .= idValue (B.billable . B._BillableId) sub,
--     "start_time" .= view B.startTime sub,
--     "end_time" .= view B.endTime sub
--   ]
-- paymentRequestDetailsJSON :: [PaymentRequestDetail Amount] -> Value
-- paymentRequestDetailsJSON r = v1 $ obj ["payment_requests" .= fmap paymentRequestDetailJSON r]
--
-- paymentRequestDetailJSON :: PaymentRequestDetail Amount -> Object
-- paymentRequestDetailJSON r = obj $ concat
--   [ ["payment_request_id" .= view () r]
--   , paymentRequestKV $ view _2 r
--   , subscriptionKV $ view _3 r
--   , billableKV $ view _4 r
--   ]
parseRecurrence :: Object -> Parser B.Recurrence
parseRecurrence o =
  let parseAnnually o' = const (pure B.Annually) <$> O.lookup "annually" o'
      parseMonthly o' = fmap B.Monthly . parseJSON <$> O.lookup "monthly" o'
      parseWeekly o' = fmap B.Weekly . parseJSON <$> O.lookup "weekly" o'
      parseOneTime o' = const (pure B.OneTime) <$> O.lookup "one-time" o'
      notFound =
        fail $ "Value " <> show o <> " does not represent a Recurrence value."
      parseV val =
        parseAnnually val
          <|> parseMonthly val
          <|> parseWeekly val
          <|> parseOneTime val
   in fromMaybe notFound $ parseV o
parseRecurrence' :: Value -> Parser B.Recurrence
parseRecurrence' = \case
  (Object o) -> parseRecurrence o
  val -> fail $ "Value " <> show val <> " is not a JSON object."

module Aftok.Snaplet.Json
  ( idJSON,
  )
where
import Aftok.Json (idValue, obj, v1)
import Control.Lens (Getter)
import Data.Aeson ((.=), Value)
import Data.UUID (UUID)
idJSON :: forall a. Text -> Getter a UUID -> a -> Value
idJSON t l a = v1 $ obj [t .= idValue l a]

    projectJSON,
    qdbProjectJSON,

import Aftok.Json (idValue)

import Aftok.Json (idValue, identifiedJSON, obj, v1)

import Control.Lens ((^.))

import Control.Lens ((^.), _1, _2, to)

projectJSON :: Project -> Value
projectJSON p =
  v1 $
    obj
      [ "projectName" .= (p ^. projectName),
        "inceptionDate" .= (p ^. inceptionDate),
        "initiator" .= (p ^. initiator . _UserId)
      ]
qdbProjectJSON :: (ProjectId, Project) -> Value
qdbProjectJSON = identifiedJSON "project" (_1 . _ProjectId) (_2 . to projectJSON)

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TypeApplications #-}

import Aftok.Interval
  ( Interval (..),
    intervalJSON,
  )

  ( AmendmentId,
    EventAmendment (..),
    EventId (..),
    FractionalPayouts,
    LogEntry (LogEntry),
    LogEvent,
    ModTime (..),
    Payouts (..),
    WorkIndex (..),
    _AmendmentId,
    _EventId,
    eventName,
    eventTime,
    payouts,
    toDepF,
    workIndex,
  )

  ( _ProjectId,

  ( CreditTo (..),
    UserId,
    ProjectId,
    _ProjectId,

import Control.Lens ((^.))

import Control.Lens ((^.), view)

import Data.Aeson ((.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A

import Data.Aeson ((.:), (.=), Value (Object), eitherDecode, object)
import Data.Aeson.Types (Pair, Parser, parseEither)
import qualified Data.List.NonEmpty as L
import qualified Data.Map.Strict as MS

----------------------
-- Handlers
----------------------

  S.Handler App App (EventId, KeyedLogEntry)

  S.Handler App App (ProjectId, UserId, KeyedLogEntry)

  case (A.eitherDecode requestBody >>= A.parseEither (parseLogEntry uid evCtr)) of

  case (eitherDecode requestBody >>= parseEither (parseLogEntry uid evCtr)) of

        (pure . (eid,))

        pure

projectWorkIndex :: S.Handler App App WorkIndex

amendEventHandler :: S.Handler App App (EventId, AmendmentId)
amendEventHandler = do
  uid <- requireUserId
  eventIdBytes <- getParam "eventId"
  eventId <-
    maybe
      (snapError 400 "eventId parameter is required")
      (pure . EventId)
      (eventIdBytes >>= U.fromASCIIBytes)
  modTime <- ModTime <$> liftIO C.getCurrentTime
  requestJSON <- readRequestJSON 4096
  either
    (snapError 400 . T.pack)
    (snapEval . amendEvent uid eventId)
    (parseEither (parseEventAmendment modTime) requestJSON)
projectWorkIndex :: S.Handler App App (WorkIndex KeyedLogEntry)

userEvents :: S.Handler App App [LogEntry]

userEvents :: S.Handler App App [KeyedLogEntry]

userWorkIndex :: S.Handler App App WorkIndex
userWorkIndex = workIndex <$> userEvents

userWorkIndex :: S.Handler App App (WorkIndex KeyedLogEntry)
userWorkIndex = workIndex (view logEntry) <$> userEvents

amendEventHandler :: S.Handler App App AmendmentId
amendEventHandler = do
  uid <- requireUserId
  eventIdBytes <- getParam "eventId"
  eventId <-
    maybe
      (snapError 400 "eventId parameter is required")
      (pure . EventId)
      (eventIdBytes >>= U.fromASCIIBytes)
  modTime <- ModTime <$> liftIO C.getCurrentTime
  requestJSON <- readRequestJSON 4096
  either
    (snapError 400 . T.pack)
    (snapEval . amendEvent uid eventId)
    (A.parseEither (parseEventAmendment modTime) requestJSON)

----------------------
-- Parsing
----------------------
parseEventAmendment ::
  ModTime ->
  Value ->
  Parser EventAmendment
parseEventAmendment t = \case
  Object o ->
    let parseA :: Text -> Parser EventAmendment
        parseA "timeChange" = TimeChange t <$> o .: "eventTime"
        parseA "creditToChange" = CreditToChange t <$> parseCreditToV2 o
        parseA "metadataChange" = MetadataChange t <$> o .: "eventMeta"
        parseA tid =
          fail . T.unpack $ "Amendment type " <> tid <> " not recognized."
     in o .: "amendment" >>= parseA
  val ->
    fail $ "Value " <> show val <> " is not a JSON object."
----------------------
-- Rendering
----------------------
logEventJSON :: LogEvent -> Value
logEventJSON ev =
  object [eventName ev .= object ["eventTime" .= (ev ^. eventTime)]]
logEntryFields :: LogEntry -> [Pair]
logEntryFields (LogEntry c ev m) =
  [ "creditTo" .= creditToJSON c,
    "event" .= logEventJSON ev,
    "eventMeta" .= m
  ]
keyedLogEntryFields :: KeyedLogEntry -> [Pair]
keyedLogEntryFields (KeyedLogEntry eid le) =
  ["eventId" .= idValue _EventId eid] <> logEntryFields le
keyedLogEntryJSON :: KeyedLogEntry -> Value
keyedLogEntryJSON kle =
  object (keyedLogEntryFields kle)

keyedLogEntryJSON :: (EventId, KeyedLogEntry) -> A.Value
keyedLogEntryJSON (eid, (pid, uid, ev)) =
  v2

extendedLogEntryJSON :: (ProjectId, UserId, KeyedLogEntry) -> Value
extendedLogEntryJSON (pid, uid, le) =
  v1

    $ [ "eventId" .= idValue _EventId eid,
        "projectId" .= idValue _ProjectId pid,

    $ [ "projectId" .= idValue _ProjectId pid,

      <> logEntryFields ev

      <> keyedLogEntryFields le
payoutsJSON :: FractionalPayouts -> Value
payoutsJSON (Payouts m) =
  v1 $
    let payoutsRec :: (CreditTo, Rational) -> Value
        payoutsRec (c, r) =
          object ["creditTo" .= creditToJSON c,
          "payoutRatio" .= r,
          "payoutPercentage" .= (fromRational @Double r * 100)]
     in obj $ ["payouts" .= fmap payoutsRec (MS.assocs m)]
workIndexJSON :: forall t. (t -> Value) -> WorkIndex t -> Value
workIndexJSON leJSON (WorkIndex widx) =
  v1 $
    obj ["workIndex" .= fmap widxRec (MS.assocs widx)]
  where
    widxRec :: (CreditTo, NonEmpty (Interval t)) -> Value
    widxRec (c, l) =
      object
        [ "creditTo" .= creditToJSON c,
          "intervals" .= (intervalJSON leJSON <$> L.toList l)
        ]
amendEventResultJSON :: (EventId, AmendmentId) -> Value
amendEventResultJSON (eid, aid) =
  object
    [ "replacement_event" .= idValue _EventId eid,
      "amendment_id" .= idValue _AmendmentId aid
    ]

import Aftok.Auction (_AuctionId)
import Aftok.Billing (_BillableId, _SubscriptionId)

import Aftok.Payments.Types (_PaymentId)

import Aftok.Snaplet.Json (idJSON)

import Aftok.Types (_ProjectId)

        serveJSON projectIdJSON $ method POST projectCreateHandler

        serveJSON (idJSON "projectId" _ProjectId) $ method POST projectCreateHandler

        serveJSON workIndexJSON $ method GET projectWorkIndex

        serveJSON (workIndexJSON keyedLogEntryJSON) $ method GET projectWorkIndex

        serveJSON keyedLogEntryJSON $ method POST (logWorkHandler f)
      amendEventRoute = serveJSON amendmentIdJSON $ method PUT amendEventHandler

        serveJSON extendedLogEntryJSON $ method POST (logWorkHandler f)
      amendEventRoute = serveJSON amendEventResultJSON $ method PUT amendEventHandler

        serveJSON (fmap logEntryJSON) $ method GET userEvents

        serveJSON (fmap keyedLogEntryJSON) $ method GET userEvents

        serveJSON workIndexJSON $ method GET userWorkIndex

        serveJSON (workIndexJSON keyedLogEntryJSON) $ method GET userWorkIndex

        serveJSON auctionIdJSON $ method POST auctionCreateHandler

        serveJSON (idJSON "auctionId" _AuctionId) $ method POST auctionCreateHandler

        serveJSON billableIdJSON $ method POST billableCreateHandler

        serveJSON (idJSON "billableId" _BillableId) $ method POST billableCreateHandler

        serveJSON subscriptionIdJSON $ method POST subscribeHandler

        serveJSON (idJSON "subscriptionId" _SubscriptionId) $ method POST subscribeHandler

        serveJSON paymentIdJSON $

        serveJSON (idJSON "paymentId" _PaymentId) $