As an additional refactoring, we now require nothing stronger than
Monad
for any component's effects.
QMEYU4MWLTSWPWEEOFRLK2IKE64BY3V5X73323WPLCGPP3TPDYGAC
J6S23MDGHVSCVVIRB6XRNSY3EGTDNWFJHV7RYLIEHBUK5KU63CFQC
WRPIYG3EUHZR6N6T74ZXZDXATRMIRLXAQ24UNUNSVTVYGMT2VDSQC
NJNMO72S7VIUV22JXB4IFPZMHWTJAOTP6EC6Z4QSKYIROSXT52MQC
3LMXT7Z6SIGLQ2OMH7OKPJPWNPN2CSGD3BKUD2NMJVCX2CSAMFYQC
EA5BFM5GMM7KNMDLTVOSUKVKMSIDD72TAFVHDVGEOUY5VELECU3QC
PT4276XCOP5NJ3GRFJLIBZKVNVAOATAY5PLWV7FWK6RZW5FTEP5AC
TUA4HMUDRRXLVOH4WPID2ZJGEIJTSCMM5OBP3E26ECYHSHG3IBDQC
QU5FW67RGCWOWT2YFM4NYMJFFHWIRPQANQBBAHBKZUY7UYMCSIMQC
ZIG57EE6RB22JGB3CT33EN2HVYCHCXBT5GROBTBMBLEMDTGQOOBQC
JXG3FCXYBDKMUD77DOM7RCIJYKB7BILC43OHHDZBE7YQRGAMUCCAC
BFZN4SUAGYNFFYVAP36BAX32DMO622PK4EPEVQQEAGC2IHTEAAPQC
RB2ETNIFLQUA6OA66DAEOXZ25ENMQGNKX5CZRSKEYHTD6BQ6NTFQC
ARX7SHY5UXL5ZZDY4BJ6LVQSC2XCI5M6FFXQ35MBWDRUHNJNICHQC
PBD7LZYQHXAA3KLH2ZUX5GW4UFML6BQ32KXZF4KZ6OYFASUYFJ5QC
UOG5H2TW5R3FSHQPJCEMNFDQZS5APZUP7OM54FIBQG7ZP4HASQ7QC
NSRSSSTRMJPPUYQANYDWGI5D3NVM6RQEVZCDUUNQAOL3OWQTD27AC
2G3GNDDUOVPF45PELJ65ZB2IXEHJJXJILFRVHZXGPXUL4BVNZJFQC
BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC
B6HWAPDPXIWH7CHK5VLMWLL6EQN6NOFZEFYO47BPUY2ZO4SL7VDAC
XTBSG4C7SCZUFOU2BTNFR6B6TCGYI35BWUV4PVTS3N7KNH5VEARQC
I2KHGVD44KT4MQJXGCTVSQKMBO6TVCY72F26TLXGWRL6PHGF6RNQC
HMDM3B557TO5RYP2IGFFC2C2VN6HYZTDQ47CJY2O37BW55DSMFZAC
QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC
RPAJLHMTUJU4AYNBOHVGHGGB4NY2NLY3BVPYN5FMWB3ZIMAUQHCQC
EFSXYZPOGA5M4DN65IEIDO7JK6U34DMQELAPHOIL2UAT6HRC66BAC
AL37SVTCKRSG4HG2PCYK5Z7QSIZZH5JHH4Q2VLMXFAXSAQRFFG4QC
ADMKQQGCGVSHHIMVQ4XFRDCG544SBJCYALSKZV45CQQBZ4ACUH2AC
HO2PFRABW6BBTE4MUKUTEGXCMJS46WGVBCNWOHO4OL52DVAB4YDAC
O5FVTOM6YFBLEPF3S576K6IMT6ZZ5VQCSB3YVXNS4CKBITKCRZ7AC
MGOF7IUFGXYQKZOKMM2GGULFFVAULEHLZDSHMUW6B5DBKVXXR74AC
import Data.DateTime (DateTime(..), adjust)
import Data.DateTime.Instant (Instant, unInstant, fromDateTime)
import Data.Date (Date, year, month, day)
import Data.DateTime (DateTime(..), adjust, date)
import Data.DateTime.Instant (Instant, unInstant, fromDateTime, toDateTime)
import Aftok.Project (Project, Project'(..), ProjectId(..))
import Aftok.Types (APIError(..), parseDate)
import Aftok.Project (Project, Project'(..), ProjectId(..), pidStr)
import Aftok.Types (APIError, System, JsonCompose, decompose, parseDatedResponse)
type Interval =
{ start :: Instant
, end :: Instant
type Event = Event' Instant
derive instance eventFunctor :: Functor Event'
instance eventFoldable :: Foldable Event' where
foldr f b = case _ of
StartEvent a -> f a b
StopEvent a -> f a b
foldl f b = case _ of
StartEvent a -> f b a
StopEvent a -> f b a
foldMap = foldMapDefaultR
instance eventTraversable :: Traversable Event' where
traverse f = case _ of
StartEvent a -> StartEvent <$> f a
StopEvent a -> StopEvent <$> f a
sequence = traverse identity
instance decodeJsonEvent :: DecodeJson (Event' String) where
decodeJson json = do
obj <- decodeJson json
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')
newtype Interval' i = Interval
{ start :: i
, end :: i
derive instance intervalEq :: (Eq i) => Eq (Interval' i)
derive instance intervalNewtype :: Newtype (Interval' i) _
type Interval = Interval' Instant
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
foldMap = foldMapDefaultR
instance intervalTraversable :: Traversable Interval' where
traverse f (Interval i) = interval <$> f i.start <*> f i.end
sequence = traverse identity
instance decodeJsonInterval :: DecodeJson (Interval' String) where
decodeJson json = do
obj <- decodeJson json
interval <$> obj .: "start" <*> obj .: "end"
interval :: forall i. i -> i -> Interval' i
interval s e = Interval { start: s, end: e }
data TimeSpan' t
= Before t
| During (Interval' t)
| After t
type TimeSpan = TimeSpan' DateTime
derive instance timeSpanFunctor :: Functor TimeSpan'
instance timeSpanFoldable :: Foldable TimeSpan' where
foldr f b = case _ of
Before a -> f a b
During x -> foldr f b x
After a -> f a b
foldl f b = case _ of
Before a -> f b a
During x -> foldl f b x
After a -> f b a
foldMap = foldMapDefaultR
instance timeSpanTraversable :: Traversable TimeSpan' where
traverse f = case _ of
Before a -> Before <$> f a
During x -> During <$> traverse f x
After a -> After <$> f a
sequence = traverse identity
:: forall query input output
. Capability Aff
-> Project.Capability Aff
-> H.Component HH.HTML query input output Aff
component caps pcaps = H.mkComponent
:: forall query input output m
. Monad m
=> System m
-> Capability m
-> Project.Capability m
-> H.Component HH.HTML query input output m
component system caps pcaps = H.mkComponent
dt@(DateTime date t) <- liftEffect nowDateTime
let startOfDay = DateTime date bottom
endOfDay = adjust (Days 1.0) startOfDay
startInstant = fromDateTime startOfDay
limits =
{ start: startInstant
, current: fromDateTime dt
, end: maybe startInstant fromDateTime endOfDay
}
llen = ilen limits.start limits.end
clen = ilen limits.start limits.current
H.put $ { limits : limits
, history : []
dt@(DateTime today t) <- lift system.nowDateTime
H.put $ { limits : { bounds: dateBounds today
, current: fromDateTime dt
}
, history : M.empty
H.modify_ (_ { selectedProject = Just p, history = [] })
timeSpan <- Before <$> lift system.nowDateTime -- FIXME, should come from a form control
intervals' <- lift $ caps.listIntervals (unwrap p).projectId timeSpan
let intervals = case intervals' of
Left err -> [] -- FIXME
Right ivals -> ivals
H.modify_ (_ { selectedProject = Just p, history = toHistory intervals })
dateBounds :: Date -> Interval
dateBounds date =
let startOfDay = DateTime date bottom
endOfDay = adjust (Days 1.0) startOfDay
startInstant = fromDateTime startOfDay
in interval startInstant (maybe startInstant fromDateTime endOfDay)
currentHistory
:: TimelineState
-> Array Interval
currentHistory st =
let currentDate = date $ toDateTime st.limits.current
in maybe [] identity (M.lookup currentDate st.history) <> fromMaybe st.active
priorHistory
:: TimelineState
-> Array (Tuple Date (Array Interval))
priorHistory st =
let currentDate = date $ toDateTime st.limits.current
in reverse <<< filter (not <<< (currentDate == _) <<< fst) $ M.toUnfoldable st.history
dateLine
:: forall action slots m
. TimelineState
-> Date
-> Array Interval
-> H.ComponentHTML action slots m
dateLine st d xs =
HH.div
[]
[ HH.text $ dateStr d <> ": " <> show (length xs :: Int)
, lineHtml (intervalHtml (dateBounds d) <$> xs)
]
dateStr :: Date -> String
dateStr d = (show <<< fromEnum $ year d) <> "-"
<> (show <<< fromEnum $ month d) <> "-"
<> (show <<< fromEnum $ day d)
data Event i
= StartEvent i
| StopEvent i
derive instance eventFunctor :: Functor Event
instance eventFoldable :: Foldable Event where
foldr f b = case _ of
StartEvent a -> f a b
StopEvent a -> f a b
foldl f b = case _ of
StartEvent a -> f b a
StopEvent a -> f b a
foldMap = foldMapDefaultR
instance eventTraversable :: Traversable Event where
traverse f = case _ of
StartEvent a -> StartEvent <$> f a
StopEvent a -> StopEvent <$> f a
sequence = traverse identity
instance decodeJsonEvent :: DecodeJson (Event String) where
decodeJson json = do
obj <- decodeJson json
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')
result <- post RF.json ("/api/projects/" <> UUID.toString pid <> "/logStart") requestBody
liftEffect <<< runExceptT $ case result of
Left err -> throwError <<< LogFailure $ Error { status: Nothing, message: printError err }
Right r -> case r.status of
StatusCode 403 ->
throwError $ LogFailure Forbidden
StatusCode 200 ->
withExceptT (LogFailure <<< ParseFailure r.body) $ do
event <- except $ decodeJson r.body
timeEvent <- traverse parseDate event
case timeEvent of
StartEvent t -> pure $ fromDateTime t
StopEvent _ -> throwError $ "Expected start event, got stop."
other ->
throwError <<< LogFailure $ Error { status: Just other, message: r.statusText }
response <- post RF.json ("/api/user/projects/" <> UUID.toString pid <> "/logStart") requestBody
liftEffect <<< runExceptT $ do
event <- withExceptT LogFailure $ parseDatedResponse response
case event of
StartEvent t -> pure t
StopEvent _ -> throwError <<< Unexpected $ "Expected start event, got stop."
result <- post RF.json ("/api/projects/" <> UUID.toString pid <> "/logEnd") requestBody
liftEffect <<< runExceptT $ case result of
Left err -> throwError <<< LogFailure $ Error { status: Nothing, message: printError err }
Right r -> case r.status of
StatusCode 403 ->
throwError $ LogFailure Forbidden
StatusCode 200 ->
withExceptT (LogFailure <<< ParseFailure r.body) $ do
event <- except $ decodeJson r.body
timeEvent <- traverse parseDate event
case timeEvent of
StartEvent _ -> throwError $ "Expected stop event, got start."
StopEvent t -> pure $ fromDateTime t
other ->
throwError <<< LogFailure $ Error { status: Just other, message: r.statusText }
response <- post RF.json ("/api/user/projects/" <> UUID.toString pid <> "/logEnd") requestBody
liftEffect <<< runExceptT $ do
event <- withExceptT LogFailure $ parseDatedResponse response
case event of
StartEvent _ -> throwError <<< Unexpected $ "Expected stop event, got start."
StopEvent t -> pure t
newtype ListIntervalsResponse a = ListIntervalsResponse
{ workIndex :: Array ({ intervals :: Array a })
}
derive instance listIntervalsResponseNewtype :: Newtype (ListIntervalsResponse a) _
derive instance listIntervalsResponseFunctor :: Functor ListIntervalsResponse
instance listIntervalsResponseFoldable :: Foldable ListIntervalsResponse where
foldr f b (ListIntervalsResponse r) = foldr f b (r.workIndex >>= _.intervals)
foldl f b (ListIntervalsResponse r) = foldl f b (r.workIndex >>= _.intervals)
foldMap = foldMapDefaultR
instance listIntervalsResponseTraversable :: Traversable ListIntervalsResponse where
traverse f (ListIntervalsResponse r) =
let traverseCreditRow r' = ({ intervals: _ }) <$> traverse f r'.intervals
in (ListIntervalsResponse <<< ({ workIndex: _ })) <$> traverse traverseCreditRow r.workIndex
sequence = traverse identity
instance listIntervalsResponseDecodeJson :: DecodeJson a => DecodeJson (ListIntervalsResponse a) where
decodeJson = map ListIntervalsResponse <<< decodeJson
_ListIntervalsResponse :: Proxy (JsonCompose ListIntervalsResponse Interval' String)
_ListIntervalsResponse = Proxy
apiListIntervals :: ProjectId -> TimeSpan -> Aff (Either TimelineError (Array Interval))
apiListIntervals pid ts = do
ts' <- liftEffect $ traverse (JD.toISOString <<< JD.fromDateTime) ts
let queryElements = case ts' of
Before t -> ["before=" <> t]
During (Interval x) -> ["after=" <> x.start, "before=" <> x.end]
After t -> ["after=" <> t]
response <- get RF.json ("/api/user/projects/" <> pidStr pid <> "/workIndex?" <> intercalate "&" queryElements)
liftEffect
<<< runExceptT
<<< map (\(ListIntervalsResponse r) -> r.workIndex >>= (_.intervals))
<<< map decompose
<<< withExceptT LogFailure
$ parseDatedResponse response
intervalDate :: Interval -> Date
intervalDate = date <<< toDateTime <<< (_.end) <<< unwrap
toHistory :: Array Interval -> M.Map Date (Array Interval)
toHistory = M.fromFoldableWith (<>) <<< map (\i -> Tuple (intervalDate i) [i])
import Affjax.StatusCode (StatusCode)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Now (now, nowDateTime)
import Affjax as AJAX
import Affjax (Response, printError)
import Affjax.StatusCode (StatusCode(..))
import Effect.Class.Console as C
import Web.Event.Event as WE
type System m =
{ log :: String -> m Unit
, error :: String -> m Unit
, now :: m Instant
, nowDateTime :: m DateTime
, preventDefault :: WE.Event -> m Unit
}
liveSystem :: System Aff
liveSystem =
{ log: liftEffect <<< C.log
, error: liftEffect <<< C.error
, now: liftEffect now
, nowDateTime: liftEffect nowDateTime
, preventDefault: liftEffect <<< WE.preventDefault
}
instance jsonComposeFoldable :: (Foldable f, Foldable g) => Foldable (JsonCompose f g) where
foldr f b = foldr f b <<< unwrap
foldl f b = foldl f b <<< unwrap
foldMap f = foldMap f <<< unwrap
instance jsonComposeTraversable :: (Traversable f, Traversable g) => Traversable (JsonCompose f g) where
traverse f = map JsonCompose <<< traverse f <<< unwrap
sequence = traverse identity
instance jsonComposeDecodeJson :: (DecodeJson (f (g a))) => DecodeJson (JsonCompose f g a) where
decodeJson json = JsonCompose <<< Compose <$> decodeJson json
decompose :: forall f g a. JsonCompose f g a -> f (g a)
decompose (JsonCompose (Compose fga)) = fga
parseDatedResponse
:: forall t
. Traversable t
=> DecodeJson (t String)
=> Either AJAX.Error (Response Json)
-> ExceptT APIError Effect (t Instant)
parseDatedResponse = case _ of
Left err ->
throwError $ Error { status: Nothing, message: printError err }
Right r -> case r.status of
StatusCode 403 ->
throwError $ Forbidden
StatusCode 200 ->
withExceptT (ParseFailure r.body) $ map fromDateTime <$> decodeDatedJson r.body
other ->
throwError $ Error { status: Just other, message: r.statusText }
:: forall query input output
. Login.Capability Aff
-> Timeline.Capability Aff
-> Project.Capability Aff
-> H.Component HH.HTML query input output Aff
component loginCap tlCap pCap = H.mkComponent
:: forall query input output m
. Monad m
=> System m
-> Login.Capability m
-> Timeline.Capability m
-> Project.Capability m
-> H.Component HH.HTML query input output m
component system loginCap tlCap pCap = H.mkComponent
#!/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
if [ -z "${PID}" ]; then
read -p "Project UUID: " PID
echo
fi
curl --verbose --insecure --user $USER \
--request GET \
"https://$AFTOK_HOST/api/projects/$PID/intervals"
loggedIntervalsHandler :: S.Handler App App (WorkIndex (NetworkId, Address))
loggedIntervalsHandler = do
projectWorkIndex :: S.Handler App App (WorkIndex (NetworkId, Address))
projectWorkIndex = do
logEntriesHandler :: S.Handler App App [LogEntry (NetworkId, Address)]
logEntriesHandler = do
userLogEntries :: S.Handler App App [LogEntry (NetworkId, Address)]
userLogEntries = do
projectRoute = serveJSON projectJSON $ method GET projectGetHandler
logEntriesRoute =
serveJSON (fmap $ logEntryJSON nmode) $ method GET logEntriesHandler
logIntervalsRoute =
serveJSON (workIndexJSON nmode) $ method GET loggedIntervalsHandler
projectRoute =
serveJSON projectJSON $ method GET projectGetHandler
projectWorkIndexRoute =
serveJSON (workIndexJSON nmode) $ method GET projectWorkIndex
logWorkBTCRoute f =
serveJSON eventIdJSON $ method POST (logWorkBTCHandler f)
amendEventRoute = serveJSON amendmentIdJSON $ method PUT amendEventHandler
-- logWorkBTCRoute f =
-- serveJSON eventIdJSON $ method POST (logWorkBTCHandler f)
amendEventRoute =
serveJSON amendmentIdJSON $ method PUT amendEventHandler
userLogEntriesRoute =
serveJSON (fmap $ logEntryJSON nmode) $ method GET userLogEntries
userWorkIndexRoute =
serveJSON (workIndexJSON nmode) $ method GET userWorkIndex
, ("projects/:projectId/logStart/:btcAddr", logWorkBTCRoute StartWork)
, ("projects/:projectId/logEnd/:btcAddr", logWorkBTCRoute StopWork)
, ("projects/:projectId/logStart" , logWorkRoute StartWork)
, ("projects/:projectId/logEnd" , logWorkRoute StopWork)
, ("projects/:projectId/logEntries" , logEntriesRoute)
, ("projects/:projectId/intervals" , logIntervalsRoute)
, ( "projects/:projectId/auctions"
, auctionCreateRoute
) -- <|> auctionListRoute
, ( "projects/:projectId/billables"
, billableCreateRoute <|> billableListRoute
)
, ("projects/:projectId/payouts", payoutsRoute)
, ("projects/:projectId/invite" , inviteRoute)
, ("projects/:projectId" , projectRoute)
, ("projects" , projectCreateRoute <|> projectListRoute)
-- , ("projects/:projectId/logStart/:btcAddr" , logWorkBTCRoute StartWork)
-- , ("projects/:projectId/logEnd/:btcAddr" , logWorkBTCRoute StopWork)
, ("user/projects/:projectId/logStart" , logWorkRoute StartWork)
, ("user/projects/:projectId/logEnd" , logWorkRoute StopWork)
, ("user/projects/:projectId/logEntries" , userLogEntriesRoute)
, ("user/projects/:projectId/workIndex" , userWorkIndexRoute)
, ("projects/:projectId/workIndex" , projectWorkIndexRoute)
, ("projects/:projectId/auctions" , auctionCreateRoute) -- <|> auctionListRoute)
, ("projects/:projectId/billables" , billableCreateRoute <|> billableListRoute)
, ("projects/:projectId/payouts" , projectPayoutsRoute)
, ("projects/:projectId/invite" , inviteRoute)
, ("projects/:projectId" , projectRoute)
, ("projects" , projectCreateRoute <|> projectListRoute)