Commit 3d6792b9 authored by MrMan's avatar MrMan

Working server w/ listing endpoint and hardcoded test

parent 123996b4
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Main where module Main where
...@@ -79,11 +80,18 @@ buildEntityStore cfg = putStrLn "[info] initializing EntityStore with config:" ...@@ -79,11 +80,18 @@ buildEntityStore cfg = putStrLn "[info] initializing EntityStore with config:"
server :: Complete AppConfig -> IO () server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg -- | Build & start the entity store server cfg = buildEntityStore entityStoreCfg -- | Build & start the entity store
>>= \entityStore -> start entityStore >>= \entityStore -> start entityStore
-- | TEST CODE, REMOVE
>> makeTestTask
>>= rightOrThrow
>>= create entityStore
>>= rightOrThrow
-- | Build the app config with the entity store -- | Build the app config with the entity store
>> pure (AppState cfg entityStore) >> pure (AppState cfg entityStore)
-- | Start the app -- | Start the app
>>= startApp >>= startApp
where where
makeTestTask = pure $ validate $ NotStartedT (Identity (TaskName "test")) (Identity (TaskDesc "test description"))
entityStoreCfg = runIdentity $ entityStoreConfig cfg entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg appPort = runIdentity $ port cfg
......
...@@ -115,6 +115,19 @@ instance ToJSON TaskWithStateAndID where ...@@ -115,6 +115,19 @@ instance ToJSON TaskWithStateAndID where
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d)) toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d)) toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d)) toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
-- | GHC says the code below is inaccessible, I choose to believe it
-- toJSON (WUUID uuid (FinishedT n d)) = toJSON $ (WUUID uuid (FinishedT n d))
-- toJSON (WUUID uuid (InProgressT n d)) = toJSON $ (WUUID uuid (InProgressT n d))
-- toJSON (WUUID uuid (NotStartedT n d)) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here toJSON _ = error "nope" -- should never get here
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'Finished))) where instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'Finished))) where
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment