From a7836ad08f70512e07e829c0fed8d2718c1a42df Mon Sep 17 00:00:00 2001
From: James Eversole <jameseversole@imarc.com>
Date: Mon, 14 Oct 2024 11:27:50 -0500
Subject: [PATCH] Add Database init effect and integrate with main entrypoint

---
 src/Database.hs | 47 +++++++++++++++++++++++++++++++++++++++++------
 src/Main.hs     |  6 +++++-
 2 files changed, 46 insertions(+), 7 deletions(-)

diff --git a/src/Database.hs b/src/Database.hs
index 573e7cf..14af35b 100644
--- a/src/Database.hs
+++ b/src/Database.hs
@@ -23,6 +23,10 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es
                              , IOE :> 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]
@@ -38,15 +42,17 @@ databaseWrite
 databaseWrite = send . DatabaseWrite
 
 runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
-runDatabaseDebug = interpret $ \ -> \case
-  DatabaseRead  (statement, values) -> do
+runDatabaseDebug = interpret $ \_ -> \case
+  DatabaseInit -> do
+    liftIOE $ putStrLn "Mocked setup of the database"
+  DatabaseRead (statement, values) -> do
     liftIOE $ putStrLn
        $ "Mocked a READ database operation with statement:\n"
       ++ show statement
       ++ " and values:\n"
       ++ show values
     pure []
-  DatabaseRead_  statement          -> do
+  DatabaseRead_ statement -> do
     liftIOE $ putStrLn "Mocked a READ database operation on all users"
     pure []
   DatabaseWrite (statement, values) -> do
@@ -55,28 +61,41 @@ runDatabaseDebug = interpret $ \ -> \case
 
 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 tableUsers
+        execute_ conn tableLogs
+        pure ()
+
     read :: (ToField a, FromRow b, DatabaseExeEffects es)
          => Query -> a -> Eff es [b]
     read statement values = do
       AppEnv { pool } <- ask
-      liftIOE $ withResource pool $ \conn -> do
+      liftWithPool pool $ \conn ->
         query conn statement (Only values)
+
     read_ :: (FromRow b, DatabaseExeEffects es) => Query -> Eff es [b]
     read_ statement = do
       AppEnv { pool } <- ask
-      liftIOE $ withResource pool $ \conn -> do
+      liftWithPool pool $ \conn ->
         query_ conn statement
+
     write :: (DatabaseExeEffects es, ToRow a) => Query -> a -> Eff es ()
     write statement values = do
       AppEnv { pool } <- ask
-      liftIOE $ withResource pool $ \conn -> do
+      liftWithPool pool $ \conn -> do
         execute conn statement values
         pure ()
 
+    liftWithPool p f = liftIOE $ withResource p f
+
 createConnectionPool :: IO (Pool Connection)
 createConnectionPool = newPool $ defaultPoolConfig
   (connectPostgreSQL "host=localhost dbname=demo")
@@ -92,3 +111,19 @@ writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
 
 deleteUser :: UserId -> (Query, UserId)
 deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)
+
+tableUsers :: Query
+tableUsers = "CREATE TABLE IF NOT EXISTS users ( \
+                \id integer NOT NULL, \
+                \name character varying(255) NOT NULL \
+              \);"
+
+tableLogs :: Query
+tableLogs = "CREATE TABLE IF NOT EXISTS 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 f382abe..0120f7b 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -22,6 +22,7 @@ main :: IO ()
 main = do
   pool <- createConnectionPool
   let env = AppEnv { pool = pool }
+  runEffStack env $ databaseInit
   run port . serve proxy $ app env
 
 app :: AppEnv -> Server AppAPI
@@ -36,7 +37,10 @@ transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler
 transformEff env = hoistServer proxy
   $ Handler
   . ExceptT
-  . runEff
+  . runEffStack env
+
+runEffStack :: AppEnv -> AppEff a -> IO (Either ServerError a)
+runEffStack env = runEff
   . runErrorNoCallStack
   . runReader env
   . runDatabaseIO