Reintroduce Debugging database handler; update main to allow for environment definition that will branch between all debug handlers or real effect handlers

.gitignore

@@ -11,3 +11,4 @@ dist*
 *.swp
 .direnv*
 .envrc
+*/result

README.md

@@ -17,7 +17,7 @@ How to navigate this codebase (as of revision 77131c4a):
   - Effect definitions
   - Utility function for lifting IO to effectful's IOE
 - Database
-  - Database effect handlers
+  - Database effect handler
   - Table definitons as functions
   - Helper functions for constructing SQL queries
 - Handlers

src/Core.hs

@@ -25,7 +25,7 @@ type AppEff =
        , Error ServerError
        ]
 
-data AppEnv = AppEnv { pool :: Pool Connection }
+data AppEnv = AppEnv { pool :: Maybe (Pool Connection) }
 
 newtype UserId = UserId Int
   deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData)

src/Database.hs

@@ -3,20 +3,21 @@ module Database where
 import Core
 import Utility
 
-import Control.Exception            (IOException)
-import Data.Aeson                   (ToJSON)
-import Data.ByteString              (ByteString)
-import Data.Maybe                   (listToMaybe)
+import Control.Exception                  (IOException)
+import Data.Aeson                         (ToJSON)
+import Data.ByteString                    (ByteString)
+import Data.Maybe                         (listToMaybe)
 import Data.Pool
-import qualified Data.Text          as T
+import qualified Data.Text                as T
+import Data.Time                          (getCurrentTime, UTCTime)
 import Database.PostgreSQL.Simple
 import Database.PostgreSQL.Simple.ToField (ToField)
 import Effectful
 import Effectful.Dispatch.Dynamic
-import Effectful.Error.Static       (Error)
+import Effectful.Error.Static             (Error)
 import Effectful.Reader.Static
-import Effectful.State.Static.Local (State, get, put, evalState)
-import Servant hiding               ((:>), throwError)
+import Effectful.State.Static.Local       (State, get, put, evalState)
+import Servant hiding                     ((:>), throwError)
 
 type instance DispatchOf Database = 'Dynamic
 
@@ -45,32 +46,73 @@ 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 ()
+    env <- ask
+    case pool env of 
+      Just pool -> liftWithPool pool $ \conn -> do
+        execute_ conn createUsersTable
+        execute_ conn createLogsTable
+        pure ()
+      Nothing -> do
+        databaseEscapeLog Error 
+          "No database pool in scope; did you mean to run the mock handler?"
+        throwDefaultISE
 
   DatabaseRead (statement, values) -> do
-    AppEnv { pool } <- ask
-    liftWithPool pool $ \conn ->
-      query conn statement (Only values)
+    env <- ask
+    case pool env of 
+      Just pool -> 
+        liftWithPool pool $ \conn -> query conn statement (Only values)
+      Nothing -> do
+        databaseEscapeLog Error 
+          "No database pool in scope; did you mean to run the mock handler?"
+        throwDefaultISE
 
   DatabaseRead_ statement -> do
-    AppEnv { pool } <- ask
-    liftWithPool pool $ \conn ->
-      query_ conn statement
+    env <- ask
+    case pool env of 
+      Just pool -> liftWithPool pool $ \conn -> query_ conn statement
+      Nothing -> do
+        databaseEscapeLog Error 
+          "No database pool in scope; did you mean to run the mock handler?"
+        throwDefaultISE
 
   DatabaseWrite (statement, values) -> do
-    AppEnv { pool } <- ask
-    liftWithPool pool $ \conn -> do
-      execute conn statement values
-      pure ()
+    env <- ask
+    case pool env of 
+      Just pool -> liftWithPool pool $ \conn -> do
+        execute conn statement values
+        pure ()
+      Nothing -> do
+        databaseEscapeLog Error 
+          "No database pool in scope; did you mean to run the mock handler?"
+        throwDefaultISE
   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"
+  DatabaseRead (statement, values) -> do
+    liftIOE $ putStrLn
+       $ "Mocked a READ database operation with statement:\n"
+      ++ show statement
+      ++ "\nValues:\n"
+      ++ show values
+    pure []
+  DatabaseRead_ statement -> do
+    liftIOE $ putStrLn "Mocked a READ database operation on all users"
+    pure []
+  DatabaseWrite (statement, values) -> do
+    liftIOE $ putStrLn
+      $ "Mocked a WRITE database operation with statement:\n"
+     ++ show statement
+     ++ "\nValues:\n"
+     ++ show values
+
 createConnectionPool :: ByteString -> IO (Pool Connection)
 createConnectionPool connectString = newPool $ defaultPoolConfig
   (connectPostgreSQL connectString)
@@ -102,3 +144,11 @@ createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \
                   \  source VARCHAR(100), \
                   \  context JSONB \
                   \);"
+
+databaseEscapeLog :: (IOE :> es, Error ServerError :> es) => LogLevel -> String -> Eff es ()
+databaseEscapeLog level msg = do
+  time   <- liftIOE getCurrentTime
+  liftIOE $ putStrLn
+     $ "TIMESTAMP: " ++ show time  ++ "\n"
+    ++ "LEVEL: "     ++ show level ++ "\n"
+    ++ "MESSAGE: "   ++ msg

src/Handlers.hs

@@ -27,8 +27,8 @@ rootHandler = (writeLog Info "Hit the root!")
 userListHandler :: CRUD es 
                 => Eff es (Html ())
 userListHandler = do
-  writeLog Info "Selected all users!"
   users <- databaseRead_ "SELECT id, name FROM users"
+  writeLog Info "Selected all users!"
   return $ V.baseDoc $ case users of
     [] -> warning "No users found"
     _  -> foldMap userHtml users

src/Logger.hs

@@ -9,8 +9,8 @@ import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Error.Static     (Error, throwError)
 import Effectful.Reader.Static
-import GHC.Generics                (Generic)
-import Servant                     hiding ((:>))
+import GHC.Generics               (Generic)
+import Servant                    hiding ((:>))
 
 type LogToDatabase es = (Database :> es, Error ServerError :> es, IOE :> es)
 
@@ -24,7 +24,7 @@ runLoggerConsole :: (Error ServerError :> es, IOE :> es)
                  => Eff (Logger : es) a -> Eff es a
 runLoggerConsole = interpret $ \_ -> \case
   WriteLog level msg -> do
-    time <- liftIOE getCurrentTime
+    time   <- liftIOE getCurrentTime
     liftIOE $ putStrLn 
        $ "TIMESTAMP: " ++ show time  ++ "\n"
       ++ "LEVEL: "     ++ show level ++ "\n"

src/Main.hs

@@ -15,19 +15,48 @@ import Network.Wai.Handler.Warp      (run)
 import Network.Wai.Middleware.Static ((>->), staticPolicy, noDots, addBase)
 import Servant hiding                ((:>), throwError, inject)
 import qualified Servant             as S
+import System.Environment            (lookupEnv)
+
+--
+-- Types
+--
+
+data RunMode = Production | Debug
+
+proxy :: Proxy AppAPI
+proxy = Proxy
 
 --
 -- Application
 --
 main :: IO ()
 main = do
-  pool   <- createConnectionPool "host=localhost dbname=demo"
-  let env = AppEnv { pool = pool }
-  runAppEff env $ databaseInit
-  run port . middleware . serve proxy $ app env
+  (envPort, envMode) <- do
+    port <- lookupEnv "PORT"
+    env  <- lookupEnv "ENVIRONMENT"
+    pure (port, env)
 
-app :: AppEnv -> Server AppAPI
-app env = hoistServer proxy (Handler . ExceptT . runAppEff env) handlers
+  let port = maybe 8080 read envPort
+      mode = case envMode of
+        Just "production" -> Production
+        _                 -> Debug
+
+  env <- case mode of 
+    Production -> do
+      dbPool <- createConnectionPool "host=localhost dbname=demo"
+      let env = AppEnv { pool = Just dbPool }
+      appEff env databaseInit
+      pure env
+    Debug      -> do
+      let env = AppEnv { pool = Nothing }
+      appDebug env databaseInit
+      pure env 
+
+  run port . middleware . serve proxy $ app env mode
+
+app :: AppEnv -> RunMode -> Server AppAPI
+app env Production = hoistServer proxy (Handler . ExceptT . appEff   env) handlers
+app env Debug      = hoistServer proxy (Handler . ExceptT . appDebug env) handlers
 
 handlers :: ServerT AppAPI AppEff
 handlers = rootHandler
@@ -39,16 +68,22 @@ handlers = rootHandler
 middleware :: Application -> Application
 middleware = staticPolicy (noDots >-> addBase "data/assets/public")
 
-runAppEff :: AppEnv -> AppEff a -> IO (Either ServerError a)
-runAppEff env = runEff
+--
+-- Effect Stacks
+--
+
+appEff :: AppEnv -> AppEff a -> IO (Either ServerError a)
+appEff env = runEff
               . runErrorNoCallStack
               . runReader env
               . runDatabaseIO
               . runLoggerPSQL
               . inject
 
-port :: Int
-port = 8080
-
-proxy :: Proxy AppAPI
-proxy = Proxy
+appDebug :: AppEnv -> AppEff a -> IO (Either ServerError a)
+appDebug env = runEff
+                . runErrorNoCallStack
+                . runReader env
+                . runDatabaseDebug
+                . runLoggerConsole
+                . inject

src/Utility.hs

@@ -20,9 +20,12 @@ liftIOE m = liftIO m `catch` \(e::IOException) -> do
     -- Log IOExceptions to stdout
     liftIO $ putStrLn $ "ERROR Exception: " ++ show e
     -- Throw a custom Servant ServerError
-    throwError $ ServerError
-      { errHTTPCode     = 500
-      , errReasonPhrase = "Internal Server Error"
-      , errBody         = renderBS V.internalServerError
-      , errHeaders      = []
-      }
+    throwDefaultISE
+
+throwDefaultISE :: (IOE :> es, Error ServerError :> es) => Eff es a
+throwDefaultISE = throwError $ ServerError
+  { errHTTPCode     = 500
+  , errReasonPhrase = "Internal Server Error"
+  , errBody         = renderBS V.internalServerError
+  , errHeaders      = []
+  }