From ff0677c53ecfed785b4cbea14a76e8689b9c20ea Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 13 Oct 2024 12:31:45 -0500 Subject: [PATCH] Line wrap --- src/Core.hs | 59 +++++++++++++++++++++++++++++++++++-------------- src/Database.hs | 5 +++-- src/Handlers.hs | 13 ++++++----- src/Main.hs | 12 +++++----- 4 files changed, 60 insertions(+), 29 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 223cbf4..d082b3e 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -22,15 +22,23 @@ import qualified Servant as S -- -- 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 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 AppAPI = Root - :<|> UserList - :<|> UserGet - :<|> UserPost + :<|> UserList + :<|> UserGet + :<|> 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_ :: (FromRow b) => Query -> Database (Eff es) [b] - DatabaseWrite :: (ToField a, Show a) => (Query, a) -> Database (Eff es) () + DatabaseRead + :: (ToField a, Show a, FromRow b) => (Query, a) -> Database (Eff es) [b] + 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 diff --git a/src/Database.hs b/src/Database.hs index c6f7d1d..8e4aed8 100644 --- a/src/Database.hs +++ b/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 diff --git a/src/Handlers.hs b/src/Handlers.hs index 2ce8486..04e4c44 100644 --- a/src/Handlers.hs +++ b/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 userId = databaseRead (queryUser userId) >>= \mUser -> +userGetHandler :: (Database :> es, Error ServerError :> es) + => 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 name = databaseWrite (writeUser name) >>= \_ -> return NoContent +userPostHandler :: ( Database :> es, Error ServerError :> es) + => String -> Eff es NoContent +userPostHandler name = + databaseWrite (writeUser name) >>= \_ -> return NoContent diff --git a/src/Main.hs b/src/Main.hs index 201c9af..31c0d21 100644 --- a/src/Main.hs +++ b/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 - $ Handler - . ExceptT - . runEff +transformEff env = hoistServer proxy + $ Handler + . ExceptT + . runEff . runErrorNoCallStack . runLoggerIO . runFileSystem