diff --git a/.gitignore b/.gitignore index 20524ef..d51ee8a 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ dist* *.swp .direnv* .envrc +*/result diff --git a/README.md b/README.md index 6ac7ca7..9716cdf 100644 --- a/README.md +++ b/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 diff --git a/src/Core.hs b/src/Core.hs index 7aea187..728f4d4 100644 --- a/src/Core.hs +++ b/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) diff --git a/src/Database.hs b/src/Database.hs index 07213d3..828b8e7 100644 --- a/src/Database.hs +++ b/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 diff --git a/src/Handlers.hs b/src/Handlers.hs index e583ee0..17e02da 100644 --- a/src/Handlers.hs +++ b/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 diff --git a/src/Logger.hs b/src/Logger.hs index 9e75fdd..ff6cd8c 100644 --- a/src/Logger.hs +++ b/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" diff --git a/src/Main.hs b/src/Main.hs index 61abc45..9c5a13d 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Utility.hs b/src/Utility.hs index 0b2db83..8ff12d9 100644 --- a/src/Utility.hs +++ b/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 = [] + }