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

Support logging to PSQL; general improvement to logging effect; cleanup and clarification of names

Browse Source
This commit is contained in:
James Eversole 2024-10-13 16:49:57 -05:00
parent 64bf8f337c
commit 715efce723
7 changed files with 125 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
HELPS.cabal
View File

@ -20,12 +20,10 @@ executable Main
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveGeneric
DerivingStrategies
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
LambdaCase
OverloadedRecordDot
OverloadedStrings
@ -45,6 +43,7 @@ executable Main
, resource-pool
, servant-server
, text
, time
, utf8-string
, warp
other-modules:

71
src/Core.hs
View File

@ -1,28 +1,45 @@
module Core where
import Control.Exception (IOException)
import Control.Monad.Catch (catch)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Text as T
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Pool (Pool)
import Database.PostgreSQL.Simple (Connection, Query)
import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
import Database.PostgreSQL.Simple.ToField (ToField)
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
import Control.Exception (IOException)
import Control.Monad.Catch (catch)
import Data.Aeson (FromJSON, ToJSON)
import Data.Pool (Pool)
import qualified Data.Text as T
import Database.PostgreSQL.Simple (Connection, Query)
import Database.PostgreSQL.Simple.FromField (FromField)
import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
import Database.PostgreSQL.Simple.ToField (ToField, toField)
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static (Error, throwError)
import Effectful.FileSystem
import Effectful.Reader.Static
import GHC.Generics (Generic)
import Servant hiding ((:>), throwError)
import qualified Servant as S
import Effectful.Error.Static (Error, throwError)
import Effectful.FileSystem (FileSystem)
import Effectful.Reader.Static (Reader)
import GHC.Generics (Generic)
import Servant hiding ((:>), throwError)
--
-- Core data types
--
data User = User { userId :: Int, userName :: String}
type AppEff = Eff '[ FileSystem
, Logger
, Database
, Reader AppEnv
, Error ServerError
, IOE
]
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
@ -33,26 +50,22 @@ instance ToRow User where
instance ToJSON User
instance FromJSON User
type AppEff = Eff '[ Database
, Reader AppEnv
, FileSystem
, Logger
, Error ServerError
, IOE
]
data AppEnv = AppEnv { pool :: Pool Connection }
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) ()
:: (ToRow a, Show a) => (Query, a) -> Database (Eff es) ()
data Logger :: Effect where
WriteLog :: String -> Logger (Eff es) ()
WriteLog :: LogLevel -> String -> Logger (Eff es) ()
data LogLevel = Info | Warning | Error
deriving (Show, Eq)
instance ToField LogLevel where
toField level = toField (T.pack (show level))
-- Utility
liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a

42
src/Database.hs
View File

@ -1,12 +1,12 @@
module Database where
import Core
import Logger
import Control.Exception (IOException)
import Data.Aeson (ToJSON)
import Data.Maybe (listToMaybe)
import Data.Pool
import qualified Data.Text as T
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.ToField (ToField)
import Effectful
@ -18,11 +18,10 @@ import Servant hiding ((:>), throwError)
type instance DispatchOf Database = 'Dynamic
type DatabaseEffects es = ( Reader AppEnv :> es
, Logger :> es
, Error ServerError :> es
, IOE :> es
)
type DatabaseExeEffects es = ( Reader AppEnv :> es
, Error ServerError :> es
, IOE :> es
)
databaseRead
:: (ToField a, Show a, Database :> es, Error ServerError :> es)
@ -34,49 +33,49 @@ databaseRead_
databaseRead_ = send . DatabaseRead_
databaseWrite
:: (ToField a, Show a, Database :> es, Error ServerError :> es)
:: (ToRow a, Show a, Database :> es, Error ServerError :> es)
=> (Query, a) -> Eff es ()
databaseWrite = send . DatabaseWrite
runDatabaseDebug :: DatabaseEffects es => Eff (Database : es) a -> Eff es a
runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
runDatabaseDebug = interpret $ \_ -> \case
DatabaseRead (statement, values) -> do
writeLog
liftIOE $ putStrLn
$ "Mocked a READ database operation with statement:\n"
++ show statement
++ " and values:\n"
++ show values
pure []
DatabaseRead_ statement -> do
writeLog "Mocked a READ database operation on all users"
liftIOE $ putStrLn "Mocked a READ database operation on all users"
pure []
DatabaseWrite (statement, values) -> do
writeLog
liftIOE $ putStrLn
$ "Mocked a WRITE database operation with a user named " ++ show values
runDatabaseIO :: DatabaseEffects es => Eff (Database : es) a -> Eff es a
runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
runDatabaseIO = interpret $ \_ -> \case
DatabaseRead (statement, values) -> read statement values
DatabaseRead_ statement -> read_ statement
DatabaseWrite (statement, values) -> write statement values
where
read :: (ToField a, FromRow b, DatabaseEffects es)
read :: (ToField a, FromRow b, DatabaseExeEffects es)
=> Query -> a -> Eff es [b]
read statement values = do
AppEnv { pool } <- ask
liftIOE $ withResource pool $ \conn -> do
query conn statement (Only values)
read_ :: (FromRow b, DatabaseEffects es) => Query -> Eff es [b]
read_ :: (FromRow b, DatabaseExeEffects es) => Query -> Eff es [b]
read_ statement = do
AppEnv { pool } <- ask
liftIOE $ withResource pool $ \conn -> do
query_ conn statement
write :: (DatabaseEffects es, ToField a) => Query -> a -> Eff es ()
write :: (DatabaseExeEffects es, ToRow a) => Query -> a -> Eff es ()
write statement values = do
AppEnv { pool } <- ask
liftIOE $ withResource pool $ \conn -> do
execute conn statement (Only values)
writeLog $ "Wrote to database using statement:\n" ++ show statement
execute conn statement values
pure ()
createConnectionPool :: IO (Pool Connection)
createConnectionPool = newPool $ defaultPoolConfig
@ -85,8 +84,11 @@ createConnectionPool = newPool $ defaultPoolConfig
60
10
queryUser :: Int -> (Query, Int)
queryUser :: UserId -> (Query, UserId)
queryUser userId = ("SELECT id, name FROM users WHERE id = ?;", userId)
writeUser :: String -> (Query, String)
writeUser name = ("INSERT INTO users (name) VALUES (?);", name)
writeUser :: T.Text -> (Query, Only T.Text)
writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
deleteUser :: UserId -> (Query, UserId)
deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)

25
src/Handlers.hs
View File

@ -2,6 +2,7 @@ module Handlers where
import Core
import Database
import Logger
import qualified Data.ByteString.Char8 as C
import Data.List
@ -13,20 +14,26 @@ import Effectful.FileSystem.IO.ByteString as EBS
import Servant hiding ((:>), throwError)
import qualified Servant as S
rootHandler :: (Error ServerError :> es) => Eff es T.Text
rootHandler = return "Hello, World!"
type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es )
userListHandler :: ( Database :> es, Error ServerError :> es) => Eff es [User]
userListHandler = databaseRead_ "SELECT id, name FROM users"
rootHandler :: (Logger :> es, Error ServerError :> es) => Eff es T.Text
rootHandler = (writeLog Info "Hit the root!") >>= \_ ->
return "Hello, World!"
userGetHandler :: (Database :> es, Error ServerError :> es)
=> Int -> 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 userId = databaseRead (queryUser userId) >>= \mUser ->
case mUser of
(a:_) -> pure a
[] -> pure (User 0 "No user found")
[] -> pure (User (UserId 0) "No user found")
userPostHandler :: ( Database :> es, Error ServerError :> es)
=> String -> 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 userId =
databaseWrite (deleteUser userId) >>= \_ -> return NoContent

44
src/Logger.hs
View File

@ -1,24 +1,48 @@
module Logger where
import Core
import Database
import Data.Time (getCurrentTime, UTCTime)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static (Error, throwError)
import Effectful.Error.Static (Error, throwError)
import Effectful.FileSystem
import Effectful.Reader.Static
import GHC.Generics (Generic)
import GHC.Generics (Generic)
import Servant hiding ((:>))
type LogToDatabase es = (Database :> es, Error ServerError :> es, IOE :> es)
type instance DispatchOf Logger = 'Dynamic
writeLog :: (Logger :> es, Error ServerError :> es) => String -> Eff es ()
writeLog = send . WriteLog
writeLog :: (Logger :> es, Error ServerError :> es)
=> LogLevel -> String -> Eff es ()
writeLog level msg = send (WriteLog level msg)
runLoggerIO :: (IOE :> es, Error ServerError :> es) =>
runLoggerConsole :: (Error ServerError :> es, IOE :> es) =>
Eff (Logger : es) a -> Eff es a
runLoggerIO = interpret $ \_ -> \case
WriteLog msg -> log msg
where
log :: (IOE :> es, Error ServerError :> es) => String -> Eff es ()
log msg = liftIOE $ putStrLn msg
runLoggerConsole = interpret $ \_ -> \case
WriteLog level msg -> do
time <- liftIOE getCurrentTime
liftIOE $ putStrLn
$ "TIMESTAMP: " ++ show time ++ "\n"
++ "LEVEL: " ++ show level ++ "\n"
++ "MESSAGE: " ++ msg
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
);
-}

5
src/Main.hs
View File

@ -31,6 +31,7 @@ app env = transformEff env
:<|> userListHandler
:<|> userGetHandler
:<|> userPostHandler
:<|> userDeleteHandler
transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler
transformEff env = hoistServer proxy
@ -38,10 +39,10 @@ transformEff env = hoistServer proxy
. ExceptT
. runEff
. runErrorNoCallStack
. runLoggerIO
. runFileSystem
. runReader env
. runDatabaseIO
. runLoggerPSQL
. runFileSystem
port :: Int
port = 8080

9
src/Routes.hs
View File

@ -14,14 +14,19 @@ type UserList = "user"
:> Get '[JSON] [User]
type UserGet = "user"
:> Capture "userId" Int
:> Capture "userId" UserId
:> Get '[JSON] User
type UserPost = "user"
:> ReqBody '[PlainText] String
:> ReqBody '[PlainText] T.Text
:> PostCreated '[PlainText] NoContent
type UserDelete = "user"
:> Capture "userId" UserId
:> Delete '[PlainText] NoContent
type AppAPI = Root
:<|> UserList
:<|> UserGet
:<|> UserPost
:<|> UserDelete