Commit 123996b4 authored by MrMan's avatar MrMan

Theoretically working server with list

parent fb66e403
......@@ -77,10 +77,11 @@ buildEntityStore cfg = putStrLn "[info] initializing EntityStore with config:"
-- | Start up the server and serve requests
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg
-- ^ Build the entity store
>>= pure . AppState cfg
-- ^ Build the app config with the entity store
server cfg = buildEntityStore entityStoreCfg -- | Build & start the entity store
>>= \entityStore -> start entityStore
-- | Build the app config with the entity store
>> pure (AppState cfg entityStore)
-- | Start the app
>>= startApp
where
entityStoreCfg = runIdentity $ entityStoreConfig cfg
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ImpredicativeTypes #-}
module Server
(buildApp)
......@@ -17,21 +18,24 @@ import Servant.Server (ServerT, Application, serve, hoistServer)
import qualified Data.Text as DT
import Util (rightOrServantErr, genericServerError)
import Types
import Data.Aeson (ToJSON(..))
import Database.SQLite.Simple (FromRow)
import Components.EntityStore.SQLite
import Data.Maybe (isJust, fromJust)
type Name = DT.Text
type Greeting = DT.Text
type TodoAPI =
"todos" :> Get '[JSON] [TaskWithState]
"todos" :> Get '[JSON] [TaskWithStateAndID]
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
listTodos :: AppHandler [TaskWithState]
listTodos :: AppHandler [TaskWithStateAndID]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID ident (Complete (Task state))]))
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID 'UUIDID (Complete (Task Some))]))
>>= rightOrServantErr genericServerError
>>= pure . (TWS <$>)
todoAPI :: Proxy TodoAPI
todoAPI = Proxy
......
......@@ -54,6 +54,8 @@ executables:
- servant-server
- warp
- transformers
- aeson
- sqlite-simple
tests:
haskell-restish-todo-test:
......
......@@ -13,6 +13,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
module Components.EntityStore.SQLite
(SQLiteEntityStore)
......@@ -48,10 +49,12 @@ data SQLiteEntityStore = SQLiteEntityStore
-- start & stop are no-ops since this component does little more than bundle together some functionality (for now)
instance Component SQLiteEntityStore where
start :: SQLiteEntityStore -> IO ()
start c = pure ()
start s = migrate s
>>= rightOrThrow
>> pure ()
stop :: SQLiteEntityStore -> IO ()
stop c = pure ()
stop s = pure ()
-- | A validated object's ToRow is just the same as it's contained object's ToRow
-- this can probably be auto-derived but let's write it manually for now.
......
......@@ -13,10 +13,12 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
module Types where
import Data.Aeson (ToJSON(..))
import GHC.Generics (Generic)
import Data.Aeson (ToJSON(..), (.=), object)
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
......@@ -36,13 +38,19 @@ import Servant (Handler)
-- Task state for abstracting over TaskState
data TaskState = Finished
| InProgress
| NotStarted deriving (Eq, Enum, Read, Show)
| NotStarted
| Some deriving (Eq, Enum, Read, Show, Generic)
instance ToJSON TaskState
-- Newtypes preventing careless
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show)
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show)
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show, Generic)
instance ToJSON TaskName
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show, Generic)
instance ToJSON TaskDesc
newtype TaskStateValue = TSV { getTStateLiteral :: DT.Text } deriving (Eq, Show)
newtype TaskStateValue = TSV { getTStateLiteral :: DT.Text } deriving (Eq, Show, Generic)
-- The beefy task class
data Task (state :: TaskState) f where
......@@ -56,10 +64,7 @@ data Task (state :: TaskState) f where
-- Once we have an UnknownStateT we can write functions that try to translate to what we expect/require and fail otherwise.
UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task state f
newtype TaskWithState = TWS { getTask :: forall (ident :: Identifier) (s :: TaskState). WithID ident (Complete (Task s)) }
instance ToJSON (TaskWithState) where
toJSON = undefined
SomeStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task 'Some f
instance Eq (Task (state :: TaskState) Identity) where
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
......@@ -103,6 +108,36 @@ type NotStartedTask = Task 'NotStarted Identity
type Partial a = a Maybe
type Complete a = a Identity
type TaskWithStateAndID = WithID 'UUIDID (Complete (Task Some))
-- | Bridge Tasks in SomeState to their actual ToJSON instances
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 "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'Finished))) where
toJSON (WUUID uuid (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WINT64 num (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Left uuid) (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Right num) (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'Finished)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'InProgress))) where
toJSON (WUUID uuid (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WINT64 num (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Left uuid) (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Right num) (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'InProgress)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'NotStarted))) where
toJSON (WUUID uuid (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WINT64 num (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Left uuid) (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Right num) (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'NotStarted)))"
----------------
-- Validation --
----------------
......@@ -383,3 +418,6 @@ type AppHandler = ReaderT AppState Handler
-- | Natural transformation for custom servant monad
appToServantHandler :: AppState -> AppHandler a -> Handler a
appToServantHandler state appM = runReaderT appM state
data Entity where
TaskE :: TaskName -> Entity
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