diff --git a/HELPS.cabal b/HELPS.cabal index 0b625f3..cb43c27 100644 --- a/HELPS.cabal +++ b/HELPS.cabal @@ -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: diff --git a/src/Core.hs b/src/Core.hs index b2a865e..5a28daa 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -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 diff --git a/src/Database.hs b/src/Database.hs index a003bc6..708d20b 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -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) diff --git a/src/Handlers.hs b/src/Handlers.hs index 04e4c44..f6e42ba 100644 --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -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 diff --git a/src/Logger.hs b/src/Logger.hs index f0cdc2c..36b2d47 100644 --- a/src/Logger.hs +++ b/src/Logger.hs @@ -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 +); +-} diff --git a/src/Main.hs b/src/Main.hs index e758fd2..5d513e1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Routes.hs b/src/Routes.hs index 2485dad..d1b5a27 100644 --- a/src/Routes.hs +++ b/src/Routes.hs @@ -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