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

Cleanup type signatures and start working on debug env run

Browse Source
This commit is contained in:
James Eversole 2024-10-16 08:10:10 -05:00
parent 0808fe130a
commit ffec891f26
5 changed files with 77 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/Core.hs
View File

@ -32,22 +32,23 @@ data AppEnv = AppEnv { pool :: Pool Connection }
newtype UserId = UserId Int
deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData)
instance ToJSON UserId
instance FromJSON UserId
instance ToRow UserId
instance FromRow UserId
data User = User { userId :: UserId, userName :: T.Text}
deriving (Show, Generic)
instance FromRow User where
fromRow = User <$> field <*> field
instance ToRow User where
toRow (User uid name) = toRow (uid, name)
instance ToJSON UserId
instance FromJSON UserId
instance ToRow UserId
instance FromRow UserId
instance ToJSON User
instance FromJSON User
instance ToRow User where
toRow (User uid name) = toRow (uid, name)
instance FromRow User where
fromRow = User <$> field <*> field
data Database :: Effect where
DatabaseInit
:: Database (Eff es) ()
@ -58,7 +59,7 @@ data Database :: Effect where
DatabaseWrite
:: (ToRow a, Show a) => (Query, a) -> Database (Eff es) ()
data Logger :: Effect where
data Logger :: Effect where
WriteLog :: LogLevel -> String -> Logger (Eff es) ()
data LogLevel = Info | Warning | Error

95
src/Database.hs
View File

@ -23,25 +23,54 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es
, IOE :> es
)
databaseInit
:: (Database :> es, Error ServerError :> es) => Eff es ()
databaseInit :: (Database :> es, Error ServerError :> es)
=> Eff es ()
databaseInit = send DatabaseInit
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
:: (ToRow a, Show a, Database :> es, Error ServerError :> es)
=> (Query, a) -> Eff es ()
databaseWrite :: (ToRow a, Show a, Database :> es, Error ServerError :> es)
=> (Query, a) -> Eff es ()
databaseWrite = send . DatabaseWrite
runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
runDatabaseIO :: DatabaseExeEffects es
=> Eff (Database : es) a -> Eff es a
runDatabaseIO = interpret $ \_ -> \case
DatabaseInit -> do
AppEnv { pool } <- ask
liftWithPool pool $ \conn -> do
execute_ conn createUsersTable
execute_ conn createLogsTable
pure ()
DatabaseRead (statement, values) -> do
AppEnv { pool } <- ask
liftWithPool pool $ \conn ->
query conn statement (Only values)
DatabaseRead_ statement -> do
AppEnv { pool } <- ask
liftWithPool pool $ \conn ->
query_ conn statement
DatabaseWrite (statement, values) -> do
AppEnv { pool } <- ask
liftWithPool pool $ \conn -> do
execute conn statement values
pure ()
where
liftWithPool :: (IOE :> es, Error ServerError :> es)
=> (Pool Connection) -> (Connection -> IO a) -> Eff es a
liftWithPool p f = liftIOE $ withResource p f
runDatabaseDebug :: DatabaseExeEffects es
=> Eff (Database : es) a -> Eff es a
runDatabaseDebug = interpret $ \_ -> \case
DatabaseInit -> do
liftIOE $ putStrLn "Mocked setup of the database"
@ -49,7 +78,7 @@ runDatabaseDebug = interpret $ \_ -> \case
liftIOE $ putStrLn
$ "Mocked a READ database operation with statement:\n"
++ show statement
++ " and values:\n"
++ "\nValues:\n"
++ show values
pure []
DatabaseRead_ statement -> do
@ -57,44 +86,10 @@ runDatabaseDebug = interpret $ \_ -> \case
pure []
DatabaseWrite (statement, values) -> do
liftIOE $ putStrLn
$ "Mocked a WRITE database operation with a user named " ++ show values
runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
runDatabaseIO = interpret $ \_ -> \case
DatabaseInit -> init
DatabaseRead (statement, values) -> read statement values
DatabaseRead_ statement -> read_ statement
DatabaseWrite (statement, values) -> write statement values
where
init :: DatabaseExeEffects es => Eff es ()
init = do
AppEnv { pool } <- ask
liftWithPool pool $ \conn -> do
execute_ conn createUsersTable
execute_ conn createLogsTable
pure ()
read :: (ToField a, FromRow b, DatabaseExeEffects es)
=> Query -> a -> Eff es [b]
read statement values = do
AppEnv { pool } <- ask
liftWithPool pool $ \conn ->
query conn statement (Only values)
read_ :: (FromRow b, DatabaseExeEffects es) => Query -> Eff es [b]
read_ statement = do
AppEnv { pool } <- ask
liftWithPool pool $ \conn ->
query_ conn statement
write :: (DatabaseExeEffects es, ToRow a) => Query -> a -> Eff es ()
write statement values = do
AppEnv { pool } <- ask
liftWithPool pool $ \conn -> do
execute conn statement values
pure ()
liftWithPool p f = liftIOE $ withResource p f
$ "Mocked a WRITE database operation with statement:\n"
++ show statement
++ "\nValues:\n"
++ show values
createConnectionPool :: IO (Pool Connection)
createConnectionPool = newPool $ defaultPoolConfig

15
src/Handlers.hs
View File

@ -14,24 +14,29 @@ import qualified Servant as S
type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es )
rootHandler :: (Logger :> es, Error ServerError :> es) => Eff es T.Text
rootHandler :: (Logger :> es, Error ServerError :> es)
=> Eff es T.Text
rootHandler = (writeLog Info "Hit the root!") >>= \_ ->
return "Hello, World!"
userListHandler :: CRUD es => Eff es [User]
userListHandler :: CRUD es
=> Eff es [User]
userListHandler = (writeLog Info "Selected all users!") >>= \_ ->
databaseRead_ "SELECT id, name FROM users"
userGetHandler :: CRUD es => UserId -> Eff es User
userGetHandler :: CRUD es
=> UserId -> Eff es User
userGetHandler userId = databaseRead (queryUser userId) >>= \mUser ->
case mUser of
(a:_) -> pure a
[] -> pure (User (UserId 0) "No user found")
userPostHandler :: CRUD es => T.Text -> Eff es NoContent
userPostHandler :: CRUD es
=> T.Text -> Eff es NoContent
userPostHandler name =
databaseWrite (writeUser name) >>= \_ -> return NoContent
userDeleteHandler :: CRUD es => UserId -> Eff es NoContent
userDeleteHandler :: CRUD es
=> UserId -> Eff es NoContent
userDeleteHandler userId =
databaseWrite (deleteUser userId) >>= \_ -> return NoContent

18
src/Logger.hs
View File

@ -19,8 +19,8 @@ writeLog :: (Logger :> es, Error ServerError :> es)
=> LogLevel -> String -> Eff es ()
writeLog level msg = send (WriteLog level msg)
runLoggerConsole :: (Error ServerError :> es, IOE :> es) =>
Eff (Logger : es) a -> Eff es a
runLoggerConsole :: (Error ServerError :> es, IOE :> es)
=> Eff (Logger : es) a -> Eff es a
runLoggerConsole = interpret $ \_ -> \case
WriteLog level msg -> do
time <- liftIOE getCurrentTime
@ -29,19 +29,9 @@ runLoggerConsole = interpret $ \_ -> \case
++ "LEVEL: " ++ show level ++ "\n"
++ "MESSAGE: " ++ msg
runLoggerPSQL :: LogToDatabase es => Eff (Logger : es) a -> Eff es a
runLoggerPSQL :: LogToDatabase es
=> Eff (Logger : es) a -> Eff es a
runLoggerPSQL = interpret $ \_ -> \case
WriteLog level msg ->
databaseWrite
("INSERT INTO logs (level, message) VALUES (?,?);", (level, msg))
{-
CREATE TABLE logs (
id SERIAL PRIMARY KEY,
level VARCHAR(10) NOT NULL,
message TEXT NOT NULL,
timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(),
source VARCHAR(100),
context JSONB
);
-}

7
src/Main.hs
View File

@ -42,6 +42,13 @@ runAppEff env = runEff
. runDatabaseIO
. runLoggerPSQL
runAppDebug :: AppEnv -> AppEff a -> IO (Either ServerError a)
runAppDebug env = runEff
. runErrorNoCallStack
. runReader env
. runDatabaseDebug
. runLoggerConsole
port :: Int
port = 8080