Line wrap

src/Core.hs

@@ -22,15 +22,23 @@ import qualified Servant                  as S
 --
 -- Routes
 --
-type Root     = Get '[PlainText] T.Text
+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 UserList = "user"
-type UserPost = "user" S.:> ReqBody '[PlainText] String S.:> PostCreated '[PlainText] NoContent
+  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 AppAPI = Root
-      :<|> UserList
+  :<|> UserList
-      :<|> UserGet
+  :<|> UserGet
-      :<|> UserPost
+  :<|> UserPost
 
 --
 -- Core data
@@ -49,27 +57,45 @@ instance FromJSON User
 --
 -- Effects
 --
-type AppEff = Eff '[Database, Reader AppEnv, FileSystem, Logger, Error ServerError, IOE]
+type AppEff = Eff '[ Database
+                   , Reader AppEnv
+                   , FileSystem
+                   , Logger
+                   , Error ServerError
+                   , IOE
+                   ]
 
 data AppEnv = AppEnv { pool :: Pool Connection }
 
 -- Database
 data Database :: Effect where
-  DatabaseRead  :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b]
+  DatabaseRead
-  DatabaseRead_ :: (FromRow b)                    =>  Query     -> Database (Eff es) [b]
+    :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b]
-  DatabaseWrite :: (ToField a, Show a)            => (Query, a) -> Database (Eff es) ()
+  DatabaseRead_
+    :: (FromRow b) => Query -> Database (Eff es) [b]
+  DatabaseWrite
+    :: (ToField a, Show a) => (Query, a) -> Database (Eff es) ()
 
 type instance DispatchOf Database = 'Dynamic
 
-type DatabaseEffects es = (Reader AppEnv :> es, Logger :> es, Error ServerError :> es, IOE :> es)
+type DatabaseEffects es = ( Reader AppEnv :> es
+                          , Logger :> es
+                          , Error ServerError :> es
+                          , IOE :> es
+                          )
 
-databaseRead  :: (ToField a, Show a, Database :> es, Error ServerError :> es) => (Query, a) -> Eff es [User]
+databaseRead
+  :: (ToField a, Show a, Database :> es, Error ServerError :> es)
+  => (Query, a) -> Eff es [User]
 databaseRead = send . DatabaseRead
 
-databaseRead_  :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User]
+databaseRead_
+  :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User]
 databaseRead_ = send . DatabaseRead_
 
-databaseWrite :: (ToField a, Show a, Database :> es, Error ServerError :> es) => (Query, a) -> Eff es ()
+databaseWrite
+  :: (ToField a, Show a, Database :> es, Error ServerError :> es)
+  => (Query, a) -> Eff es ()
 databaseWrite = send . DatabaseWrite
 
 -- Logger
@@ -81,7 +107,8 @@ type instance DispatchOf Logger = 'Dynamic
 writeLog :: (Logger :> es, Error ServerError :> es) => String -> Eff es ()
 writeLog = send . WriteLog
 
-runLoggerIO :: (IOE :> es, Error ServerError :> es) => Eff (Logger : es) a -> Eff es a
+runLoggerIO :: (IOE :> es, Error ServerError :> es) =>
+  Eff (Logger : es) a -> Eff es a
 runLoggerIO = interpret $ \_ -> \case
   WriteLog msg -> log msg
   where

src/Database.hs

@@ -6,7 +6,7 @@ import Control.Exception            (IOException)
 import Data.Aeson                   (ToJSON)
 import Data.Maybe                   (listToMaybe)
 import Data.Pool
-import Database.PostgreSQL.Simple 
+import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.ToField (ToField)
 import Effectful
 import Effectful.Dispatch.Dynamic
@@ -37,7 +37,8 @@ runDatabaseIO = interpret $ \_ -> \case
   DatabaseRead_  statement          -> read_ statement
   DatabaseWrite (statement, values) -> write statement values
   where
-    read :: (ToField a, FromRow b, DatabaseEffects es) => Query -> a -> Eff es [b]
+    read :: (ToField a, FromRow b, DatabaseEffects es)
+         => Query -> a -> Eff es [b]
     read statement values = do
       AppEnv { pool } <- ask
       liftIOE $ withResource pool $ \conn -> do

src/Handlers.hs

@@ -16,14 +16,17 @@ import qualified Servant                  as S
 rootHandler :: (Error ServerError :> es) => Eff es T.Text
 rootHandler = return "Hello, World!"
 
-userListHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Eff es [User]
+userListHandler :: ( Database :> es, Error ServerError :> es) => Eff es [User]
 userListHandler = databaseRead_ "SELECT id, name FROM users"
 
-userGetHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Int -> Eff es User
+userGetHandler :: (Database :> es, Error ServerError :> es)
-userGetHandler userId = databaseRead (queryUser userId) >>= \mUser -> 
+               => Int -> Eff es User
+userGetHandler userId = databaseRead (queryUser userId) >>= \mUser ->
   case mUser of
     (a:_) -> pure a
     []    -> pure (User 0 "No user found")
 
-userPostHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => String -> Eff es NoContent
+userPostHandler :: ( Database :> es, Error ServerError :> es)
-userPostHandler name = databaseWrite (writeUser name) >>= \_ -> return NoContent
+                => String -> Eff es NoContent
+userPostHandler name =
+  databaseWrite (writeUser name) >>= \_ -> return NoContent

src/Main.hs

@@ -7,7 +7,7 @@ import Handlers
 import Control.Monad.Except     (ExceptT (ExceptT))
 import Data.List
 import Effectful
-import Effectful.Error.Static   (Error, runError, runErrorNoCallStack, throwError)
+import Effectful.Error.Static   (Error, runErrorNoCallStack, throwError)
 import Effectful.FileSystem
 import Effectful.Reader.Static
 import Network.Wai.Handler.Warp (run)
@@ -24,17 +24,17 @@ main = do
   run port $ serve proxy $ app env
 
 app :: AppEnv -> Server AppAPI
-app env = transformEff env 
+app env = transformEff env
         $ rootHandler
      :<|> userListHandler
      :<|> userGetHandler
      :<|> userPostHandler
 
 transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler
-transformEff env = hoistServer proxy 
+transformEff env = hoistServer proxy
-  $ Handler 
+  $ Handler
-  . ExceptT 
+  . ExceptT
-  . runEff 
+  . runEff
   . runErrorNoCallStack
   . runLoggerIO
   . runFileSystem