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

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:

src/Core.hs

@@ -1,28 +1,45 @@
 module Core where
 
-import Control.Exception                  (IOException)
+import Control.Exception                    (IOException)
-import Control.Monad.Catch                (catch)
+import Control.Monad.Catch                  (catch)
-import Data.Aeson                         (FromJSON, ToJSON)
+import Data.Aeson                           (FromJSON, ToJSON)
-import qualified Data.Text                as T
+import Data.Pool                            (Pool)
-import Data.ByteString.Lazy.UTF8          (fromString)
+import qualified Data.Text                  as T
-import Data.Pool                          (Pool)
+import Database.PostgreSQL.Simple           (Connection, Query)
-import Database.PostgreSQL.Simple         (Connection, Query)
+import Database.PostgreSQL.Simple.FromField (FromField)
-import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
+import Database.PostgreSQL.Simple.FromRow   (FromRow, field, fromRow)
-import Database.PostgreSQL.Simple.ToField (ToField)
+import Database.PostgreSQL.Simple.ToField   (ToField, toField)
-import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
+import Database.PostgreSQL.Simple.ToRow     (ToRow, toRow)
 import Effectful
 import Effectful.Dispatch.Dynamic
-import Effectful.Error.Static             (Error, throwError)
+import Effectful.Error.Static               (Error, throwError)
-import Effectful.FileSystem
+import Effectful.FileSystem                 (FileSystem)
-import Effectful.Reader.Static
+import Effectful.Reader.Static              (Reader)
-import GHC.Generics                       (Generic)
+import GHC.Generics                         (Generic)
-import Servant hiding                     ((:>), throwError)
+import Servant hiding                       ((:>), throwError)
-import qualified Servant                  as S
 
 --
 -- 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

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 
+type DatabaseExeEffects es = ( Reader AppEnv :> es 
-                          , Logger :> es
+                             , Error ServerError :> es
-                          , Error ServerError :> es
+                             , IOE :> 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)
+        execute conn statement values
-      writeLog $ "Wrote to database using statement:\n" ++ show statement
+        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 :: T.Text -> (Query, Only T.Text)
-writeUser name   = ("INSERT INTO users (name) VALUES (?);", name)
+writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
+
+deleteUser :: UserId -> (Query, UserId)
+deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)

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
+type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es )
-rootHandler = return "Hello, World!"
 
-userListHandler :: ( Database :> es, Error ServerError :> es) => Eff es [User]
+rootHandler :: (Logger :> es, Error ServerError :> es) => Eff es T.Text
-userListHandler = databaseRead_ "SELECT id, name FROM users"
+rootHandler = (writeLog Info "Hit the root!") >>= \_ ->
+  return "Hello, World!"
 
-userGetHandler :: (Database :> es, Error ServerError :> es)
+userListHandler :: CRUD es => Eff es [User]
-               => Int -> 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)
+userPostHandler :: CRUD es => T.Text -> Eff es NoContent
-                => String -> Eff es NoContent
 userPostHandler name =
   databaseWrite (writeUser name) >>= \_ -> return NoContent
+
+userDeleteHandler :: CRUD es => UserId -> Eff es NoContent
+userDeleteHandler userId =
+  databaseWrite (deleteUser userId) >>= \_ -> return NoContent

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 :: (Logger :> es, Error ServerError :> es) 
-writeLog = send . WriteLog
+         => 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
+runLoggerConsole = interpret $ \_ -> \case
-  WriteLog msg -> log msg
+  WriteLog level msg -> do
-  where
+    time <- liftIOE getCurrentTime
-    log :: (IOE :> es, Error ServerError :> es) => String -> Eff es ()
+    liftIOE $ putStrLn 
-    log msg = liftIOE $ putStrLn msg
+       $ "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
+);
+-}

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

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