init

src/Core.hs

@@ -0,0 +1,54 @@
+module Core where
+
+import Control.Exception                  (IOException)
+import Data.Aeson                         (FromJSON, ToJSON)
+import qualified Data.Text                as T
+import Database.PostgreSQL.Simple         (Query)
+import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
+import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Error.Static             (Error)
+import Effectful.FileSystem
+import GHC.Generics                       (Generic)
+import Servant hiding                     ((:>))
+import qualified Servant                  as S
+
+-- Core data
+data User = User { userId :: Int, userName :: String}
+  deriving (Show, Generic)
+
+instance FromRow User where
+    fromRow = User <$> field <*> field
+instance ToRow User where
+    toRow (User uid name) = toRow (uid, name)
+
+instance ToJSON User
+instance FromJSON User
+
+-- Effects
+type AppEff = Eff '[Database, FileSystem, Error ServerError, IOE]
+
+data Database :: Effect where
+  DatabaseRead  :: (Query, Int)    -> Database (Eff es) (Maybe User)
+  DatabaseWrite :: (Query, String) -> Database (Eff es) ()
+
+type instance DispatchOf Database = 'Dynamic
+
+databaseRead  :: (Database :> es, Error ServerError :> es) => (Query, Int) -> Eff es (Maybe User)
+databaseRead  = send . DatabaseRead
+
+databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> Eff es ()
+databaseWrite = send . DatabaseWrite
+
+-- Routes
+type Root     = Get '[PlainText] T.Text
+type UserList = "user" S.:> Get '[JSON] [User]
+type UserGet  = "user" S.:> Capture "userId"     Int    S.:> Get  '[JSON] User
+type UserPost = "user" S.:> ReqBody '[PlainText] String S.:> PostCreated '[PlainText] NoContent
+
+type API = Root
+      :<|> UserList
+      :<|> UserGet
+      :<|> UserPost