James/HELPS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Line wrap

Browse Source
This commit is contained in:
James Eversole 2024-10-13 12:31:45 -05:00
parent 5a72b5fcdb
commit ff0677c53e
4 changed files with 60 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
src/Core.hs
View File

@ -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

5
src/Database.hs
View File

@ -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

13
src/Handlers.hs
View File

@ -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

12
src/Main.hs
View File

@ -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