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

.gitignore

@@ -0,0 +1,14 @@
+WD
+bin/
+data
+/result
+/Dockerfile
+/docker-stack.yml
+dist*
+*~
+.env
+.stack-work/
+*.swp
+.direnv*
+.envrc
+*/result

HELPS.cabal

@@ -1,4 +1,4 @@
-cabal-version: 1.12
+cabal-version: 3.0
 
 name:           HELPS
 version:        0.0.1
@@ -9,13 +9,29 @@ copyright:      James Eversole
 license:        ISC
 license-file:   LICENSE
 build-type:     Simple
+with-compiler:  ghc-9.6.6
+documentation:  True
 extra-source-files:
     README
 
-executable Main
+common global
-  main-is: Main.hs
+  build-depends: 
-  hs-source-dirs:
+    base
-      src
+    , aeson
+    , bytestring
+    , effectful
+    , exceptions
+    , lucid
+    , mtl
+    , postgresql-simple
+    , resource-pool
+    , servant-lucid
+    , servant-server
+    , text
+    , time
+    , utf8-string
+    , wai-middleware-static
+    , warp
   default-extensions:
       BlockArguments
       ConstraintKinds
@@ -31,25 +47,26 @@ executable Main
       StrictData
       TypeFamilies
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
-  build-depends:
+  default-language: GHC2021
-    base
+
-    , aeson
+executable Main
-    , bytestring
+  import: global
-    , effectful
+  hs-source-dirs:
-    , exceptions
+    src
-    , lucid
+  main-is: Main.hs
-    , mtl
-    , postgresql-simple
-    , resource-pool
-    , servant-server
-    , text
-    , time
-    , utf8-string
-    , warp
   other-modules:
     Core
     Database
     Handlers
     Logger
     Routes
-  default-language: GHC2021
+    Utility
+    Views
+  build-depends: 
+    HELPS
+
+library 
+  import: global
+  hs-source-dirs:
+    src
+  exposed-modules: Core, Database, Handlers, Logger, Main, Routes, Utility, Views

README.md

@@ -8,4 +8,29 @@ A work in progress Nix starting template for web projects utilizing
 - [PostgreSQL](https://www.postgresql.org/)
 - [Servant](https://github.com/haskell-servant/servant)
 
-The repository has a simple CRUD implementation of a "Users" API which demonstrates how to use included effects, create your own effects, and bubble errors to Servant's `ServerError` type.
+The repository has a simple CRUD implementation of a "Users" API which demonstrates how to use included effects, create your own effects, write/compose HTML using Lucid, and bubble errors to Servant's `ServerError` type.
+
+How to navigate this codebase (as of revision 77131c4a):
+
+- Core
+  - Application data types
+  - Effect definitions
+  - Utility function for lifting IO to effectful's IOE
+- Database
+  - Database effect handler
+  - Table definitons as functions
+  - Helper functions for constructing SQL queries
+- Handlers
+  - Request handlers in the Eff monad
+- Logger
+  - Logging implementation using the Database effect for logging to PSQL
+  - Logging implementation to stdout
+- Main
+  - Application entry point and initialization
+  - Creates a PostgreSQL connection pool to include in the Reader effect
+  - Effect stack runner for real database interactions
+  - Debugging effect stack that mocks database interactions and logs to stdout instead
+- Routes
+  - Type level route definitions for Servant
+- Views
+  - Lucid2 HTML templating and composition functions

flake.nix

@@ -12,24 +12,28 @@
       packageName       = "HELPS";
       containerPackageName = "${packageName}-container";
 
+      c2n = haskellPackages.callCabal2nix packageName self rec {};
+      HELPS = c2n.overrideAttrs (old: {
+        doHaddock = true;
+        enableSeparateDocOutput = false;
+        enableSharedExecutables = false;
+        enableSharedLibraries = false;
+      });
+
       haskellPackages = pkgs.haskellPackages;
-
-      enableSharedExecutables = false;
-      enableSharedLibraries = false;
-
-      HELPS = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
     in {
-      packages.${packageName} =
+      packages.${packageName} = pkgs.haskell.lib.justStaticExecutables HELPS;
-        haskellPackages.callCabal2nix packageName self rec {};
+      packages.HELPSDocs = HELPS;
 
       packages.default = self.packages.${system}.${packageName};
       defaultPackage = self.packages.${system}.default;
 
       devShells.default = pkgs.mkShell {
         buildInputs = with pkgs; [
-          ghcid
+          pkgs.haskellPackages.cabal-install
-          cabal-install
+          pkgs.haskellPackages.ghc
-          ghc
+          pkgs.haskellPackages.ghcid
+          pkgs.haskellPackages.haskell-language-server
         ];
         inputsFrom = builtins.attrValues self.packages.${system};
       };

hie.yaml

@@ -0,0 +1,3 @@
+cradle:
+  direct:
+    arguments: ["--print-libdir"]

src/Core.hs

@@ -1,7 +1,5 @@
 module Core where
 
-import Control.Exception                    (IOException)
-import Control.Monad.Catch                  (catch)
 import Data.Aeson                           (FromJSON, ToJSON)
 import Data.Pool                            (Pool)
 import qualified Data.Text                  as T
@@ -11,42 +9,44 @@ 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.Error.Static               (Error, throwError)
+import Effectful.Error.Static               (Error)
 import Effectful.Reader.Static              (Reader)
 import GHC.Generics                         (Generic)
-import Servant hiding                       ((:>), throwError)
+import Servant hiding                       ((:>))
+import Servant.HTML.Lucid
 
 --
 -- Core data types
 --
-type AppEff = Eff '[ Logger
+type AppEff = 
-                   , Database
+  Eff '[ Logger
-                   , Reader AppEnv
+       , Database
-                   , Error ServerError
+       , Reader AppEnv
-                   , IOE
+       , 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)
 
-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
+instance ToJSON   UserId
-    fromRow = User <$> field <*> field
+instance FromJSON UserId
-instance ToRow User where
+
-    toRow (User uid name) = toRow (uid, name)
+instance ToRow    UserId
+instance FromRow  UserId
 
 instance ToJSON User
 instance FromJSON User
 
+instance ToRow User where
+    toRow (User uid name) = toRow (uid, name)
+instance FromRow User where
+    fromRow = User <$> field <*> field
+
 data Database :: Effect where
   DatabaseInit
     :: Database (Eff es) ()
@@ -57,7 +57,7 @@ data Database :: Effect where
   DatabaseWrite
     :: (ToRow a, Show a) => (Query, a) -> Database (Eff es) ()
 
-data Logger :: Effect where
+data Logger  :: Effect where
     WriteLog :: LogLevel -> String -> Logger (Eff es) ()
 
 data LogLevel = Info | Warning | Error
@@ -65,17 +65,3 @@ data LogLevel = Info | Warning | Error
 
 instance ToField LogLevel where
   toField level = toField (T.pack (show level))
-
--- Utility
-liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
--- Lift IO into Eff and catch IOExceptions
-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         = "This incident will be investigated."
-      , errHeaders      = []
-      }

src/Database.hs

@@ -1,20 +1,23 @@
 module Database where
 
 import Core
+import Utility
 
-import Control.Exception            (IOException)
+import Control.Exception                  (IOException)
-import Data.Aeson                   (ToJSON)
+import Data.Aeson                         (ToJSON)
-import Data.Maybe                   (listToMaybe)
+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 Effectful.State.Static.Local       (State, get, put, evalState)
-import Servant hiding               ((:>), throwError)
+import Servant hiding                     ((:>), throwError)
 
 type instance DispatchOf Database = 'Dynamic
 
@@ -23,25 +26,73 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es
                              , IOE :> es
                              )
 
-databaseInit 
+databaseInit :: (Database :> es, Error ServerError :> es) 
-  :: (Database :> es, Error ServerError :> es) => Eff es ()
+             => Eff es ()
 databaseInit = send DatabaseInit
 
-databaseRead
+databaseRead :: (ToField a, Show a, Database :> es, Error ServerError :> es)
-  :: (ToField a, Show a, Database :> es, Error ServerError :> es)
+             => (Query, a) -> Eff es [User]
-  => (Query, a) -> Eff es [User]
 databaseRead = send . DatabaseRead
 
-databaseRead_
+databaseRead_ :: (Database :> es, Error ServerError :> es) 
-  :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User]
+              => Query -> Eff es [User]
 databaseRead_ = send . DatabaseRead_
 
-databaseWrite
+databaseWrite :: (ToRow a, Show a, Database :> es, Error ServerError :> es)
-  :: (ToRow a, Show a, Database :> es, Error ServerError :> es)
+              => (Query, a) -> Eff es ()
-  => (Query, a) -> Eff es ()
 databaseWrite = send . DatabaseWrite
 
-runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
+runDatabaseIO :: DatabaseExeEffects es 
+              => Eff (Database : es) a -> Eff es a
+runDatabaseIO = interpret $ \_ -> \case
+  DatabaseInit -> do
+    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
+    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
+    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
+    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"
@@ -49,7 +100,7 @@ runDatabaseDebug = interpret $ \_ -> \case
     liftIOE $ putStrLn
        $ "Mocked a READ database operation with statement:\n"
       ++ show statement
-      ++ " and values:\n"
+      ++ "\nValues:\n"
       ++ show values
     pure []
   DatabaseRead_ statement -> do
@@ -57,48 +108,14 @@ runDatabaseDebug = interpret $ \_ -> \case
     pure []
   DatabaseWrite (statement, values) -> do
     liftIOE $ putStrLn
-      $ "Mocked a WRITE database operation with a user named " ++ show values
+      $ "Mocked a WRITE database operation with statement:\n"
+     ++ show statement
+     ++ "\nValues:\n"
+     ++ show values
 
-runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
+createConnectionPool :: ByteString -> IO (Pool Connection)
-runDatabaseIO = interpret $ \_ -> \case
+createConnectionPool connectString = newPool $ defaultPoolConfig
-  DatabaseInit                      -> init
+  (connectPostgreSQL connectString)
-  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
-      liftWithPool pool $ \conn ->
-        query conn statement (Only values)
-
-    read_ :: (FromRow b, DatabaseExeEffects es) => Query -> Eff es [b]
-    read_ statement = do
-      AppEnv { pool } <- ask
-      liftWithPool pool $ \conn ->
-        query_ conn statement
-
-    write :: (DatabaseExeEffects es, ToRow a) => Query -> a -> Eff es ()
-    write statement values = do
-      AppEnv { pool } <- ask
-      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")
   close
   60
   10
@@ -112,18 +129,26 @@ writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
 deleteUser :: UserId -> (Query, UserId)
 deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)
 
-tableUsers :: Query
+createUsersTable :: Query
-tableUsers = "CREATE TABLE IF NOT EXISTS users ( \
+createUsersTable = "CREATE TABLE IF NOT EXISTS users ( \
-                \id integer NOT NULL, \
+                   \  id SERIAL PRIMARY KEY, \
-                \name character varying(255) NOT NULL \
+                   \  name character varying(255) NOT NULL \
-              \);"
+                   \);"
 
-tableLogs :: Query
+createLogsTable :: Query
-tableLogs = "CREATE TABLE IF NOT EXISTS logs ( \
+createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \
-              \  id SERIAL PRIMARY KEY, \
+                  \  id SERIAL PRIMARY KEY, \
-              \  level VARCHAR(10) NOT NULL, \
+                  \  level VARCHAR(10) NOT NULL, \
-              \  message TEXT NOT NULL, \
+                  \  message TEXT NOT NULL, \
-              \  timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \
+                  \  timestamp TIMESTAMPTZ NOT NULL DEFAULT NOW(), \
-              \  source VARCHAR(100), \
+                  \  source VARCHAR(100), \
-              \  context JSONB \
+                  \  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

@@ -3,35 +3,49 @@ module Handlers where
 import Core
 import Database
 import Logger
+import Views                              as V
 
 import qualified Data.ByteString.Char8    as C
 import Data.List
 import qualified Data.Text                as T
 import Effectful
 import Effectful.Error.Static             (Error, throwError)
+import Lucid                              (Html)
 import Servant hiding                     ((:>), throwError)
-import qualified Servant                  as S
+import Servant.HTML.Lucid
 
+-- Type synonym for common CRUD constraints like interacting with a database,
+-- logging, and the possibility to throw an error.
 type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es )
 
-rootHandler :: (Logger :> es, Error ServerError :> es) => Eff es T.Text
+-- Remember to drop effect constraints you don't need!
-rootHandler = (writeLog Info "Hit the root!") >>= \_ ->
+rootHandler :: (Logger :> es, Error ServerError :> es)
-  return "Hello, World!"
+            => Eff es (Html ())
+rootHandler = (writeLog Info "Hit the root!")
+    >>= \_ -> return V.root
 
-userListHandler :: CRUD es => Eff es [User]
+userListHandler :: CRUD es 
-userListHandler = (writeLog Info "Selected all users!") >>= \_ ->
+                => Eff es (Html ())
-  databaseRead_ "SELECT id, name FROM users"
+userListHandler = do
+  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
 
-userGetHandler :: CRUD es => UserId -> Eff es User
+userGetHandler :: CRUD es 
+               => UserId -> Eff es User
 userGetHandler userId = databaseRead (queryUser userId) >>= \mUser ->
   case mUser of
     (a:_) -> pure a
     []    -> pure (User (UserId 0) "No user found")
 
-userPostHandler :: CRUD es => T.Text -> 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 :: CRUD es 
+                  => UserId -> Eff es NoContent
 userDeleteHandler userId =
   databaseWrite (deleteUser userId) >>= \_ -> return NoContent

src/Logger.hs

@@ -2,14 +2,15 @@ module Logger where
 
 import Core
 import Database
+import Utility
 
 import Data.Time                  (getCurrentTime, UTCTime)
 import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Error.Static     (Error, throwError)
 import Effectful.Reader.Static
-import GHC.Generics                (Generic)
+import GHC.Generics               (Generic)
-import Servant                     hiding ((:>))
+import Servant                    hiding ((:>))
 
 type LogToDatabase es = (Database :> es, Error ServerError :> es, IOE :> es)
 
@@ -19,29 +20,19 @@ writeLog :: (Logger :> es, Error ServerError :> es)
          => LogLevel -> String -> Eff es ()
 writeLog level msg = send (WriteLog level msg)
 
-runLoggerConsole :: (Error ServerError :> es, IOE :> es) => 
+runLoggerConsole :: (Error ServerError :> es, IOE :> es) 
-  Eff (Logger : es) a -> Eff es a
+                 => 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"
       ++ "MESSAGE: "   ++ msg
 
-runLoggerPSQL :: LogToDatabase es => Eff (Logger : es) a -> Eff es a
+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

@@ -6,48 +6,84 @@ import Handlers
 import Logger
 import Routes
 
-import Control.Monad.Except     (ExceptT (ExceptT))
+import Control.Monad.Except          (ExceptT (ExceptT))
 import Data.List
 import Effectful
-import Effectful.Error.Static   (Error, runErrorNoCallStack, throwError)
+import Effectful.Error.Static        (Error, runErrorNoCallStack, throwError)
 import Effectful.Reader.Static
-import Network.Wai.Handler.Warp (run)
+import Network.Wai.Handler.Warp      (run)
-import Servant hiding           ((:>), throwError)
+import Network.Wai.Middleware.Static ((>->), staticPolicy, noDots, addBase)
-import qualified Servant        as S
+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
+  (envPort, envMode) <- do
-  let env = AppEnv { pool = pool }
+    port <- lookupEnv "PORT"
-  runEffStack env $ databaseInit
+    env  <- lookupEnv "ENVIRONMENT"
-  run port . serve proxy $ app env
+    pure (port, env)
 
-app :: AppEnv -> Server AppAPI
+  let port = maybe 8080 read envPort
-app env = transformEff env
+      mode = case envMode of
-        $ rootHandler
+        Just "production" -> Production
-     :<|> userListHandler
+        _                 -> Debug
-     :<|> userGetHandler
-     :<|> userPostHandler
-     :<|> userDeleteHandler
 
-transformEff :: AppEnv -> ServerT AppAPI AppEff -> ServerT AppAPI Handler
+  env <- case mode of 
-transformEff env = hoistServer proxy
+    Production -> do
-  $ Handler
+      dbPool <- createConnectionPool "host=localhost dbname=demo"
-  . ExceptT
+      let env = AppEnv { pool = Just dbPool }
-  . runEffStack env
+      appEff env databaseInit
+      pure env
+    Debug      -> do
+      let env = AppEnv { pool = Nothing }
+      appDebug env databaseInit
+      pure env 
 
-runEffStack :: AppEnv -> AppEff a -> IO (Either ServerError a)
+  run port . middleware . serve proxy $ app env mode
-runEffStack env = runEff
-  . runErrorNoCallStack
-  . runReader env
-  . runDatabaseIO
-  . runLoggerPSQL
 
-port :: Int
+app :: AppEnv -> RunMode -> Server AppAPI
-port = 8080
+app env Production = hoistServer proxy (Handler . ExceptT . appEff   env) handlers
+app env Debug      = hoistServer proxy (Handler . ExceptT . appDebug env) handlers
 
-proxy :: Proxy AppAPI
+handlers :: ServerT AppAPI AppEff
-proxy = Proxy
+handlers = rootHandler
+      :<|> userListHandler
+      :<|> userGetHandler
+      :<|> userPostHandler
+      :<|> userDeleteHandler
+
+middleware :: Application -> Application
+middleware = staticPolicy (noDots >-> addBase "data/assets/public")
+
+--
+-- Effect Stacks
+--
+
+appEff :: AppEnv -> AppEff a -> IO (Either ServerError a)
+appEff env = runEff
+              . runErrorNoCallStack
+              . runReader env
+              . runDatabaseIO
+              . runLoggerPSQL
+              . inject
+
+appDebug :: AppEnv -> AppEff a -> IO (Either ServerError a)
+appDebug env = runEff
+                . runErrorNoCallStack
+                . runReader env
+                . runDatabaseDebug
+                . runLoggerConsole
+                . inject

src/Routes.hs

@@ -3,15 +3,17 @@ module Routes where
 import Core
   
 import qualified Data.Text as T
+import Lucid                  (Html)
 import Servant
+import Servant.HTML.Lucid
 
 --
 -- Routes
 --
-type Root = Get '[PlainText] T.Text
+type Root = Get '[HTML] (Html ())
 
 type UserList = "user"
-  :> Get '[JSON] [User]
+  :> Get '[HTML] (Html ())
 
 type UserGet = "user"
   :> Capture "userId" UserId 

src/Utility.hs

@@ -0,0 +1,31 @@
+module Utility where
+
+import qualified Views        as V
+
+import Control.Exception      (IOException)
+import Control.Monad.Catch    (catch)
+import Effectful
+import Effectful.Error.Static (Error, throwError)
+import Lucid                  (renderBS)
+import Servant                ( ServerError(..)
+                              , errHTTPCode
+                              , errReasonPhrase
+                              , errBody
+                              , errHeaders
+                              )
+
+liftIOE :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
+-- Lift IO into Eff and catch IOExceptions
+liftIOE m = liftIO m `catch` \(e::IOException) -> do
+    -- Log IOExceptions to stdout
+    liftIO $ putStrLn $ "ERROR Exception: " ++ show e
+    -- Throw a custom Servant ServerError
+    throwDefaultISE
+
+throwDefaultISE :: (IOE :> es, Error ServerError :> es) => Eff es a
+throwDefaultISE = throwError $ ServerError
+  { errHTTPCode     = 500
+  , errReasonPhrase = "Internal Server Error"
+  , errBody         = renderBS V.internalServerError
+  , errHeaders      = []
+  }

src/Views.hs

@@ -0,0 +1,41 @@
+module Views where
+
+import Core
+
+import Data.Text
+import Data.String    (fromString)
+import Effectful
+import Lucid
+
+baseDoc :: Html () -> Html ()
+baseDoc a = doctypehtml_ $ do
+  head_ $ do
+    meta_ [ name_ "viewport", content_ "width=device-width, initial-scale=1.0" ]
+    title_ "HELPS Template!"
+    link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css"]
+    body_ $ do
+      main_ [ class_ "container" ] a
+
+root :: Html ()
+root = baseDoc $ do
+  h1_ "Welcome to HELPS!"
+  p_  "Haskell, Effectful, Lucid, PostgreSQL, Servant"
+  p_  "You can get started by reviewing the README.md for directions on using \
+     \ this template for your own projects."
+
+userHtml :: User -> Html ()
+userHtml user = div_ [] $ do
+  ul_ $ do
+    li_ $ do
+      "Username: " >> toHtml (show $ userName user)
+      ul_ $ li_ $ "User ID: " >> toHtml (show $ userId user)
+
+warning :: String -> Html ()
+warning s = p_ [class_ "warning"] (toHtml s)
+
+internalServerError :: Html ()
+internalServerError = baseDoc $ do
+  div_ [ style_ "text-align: center; margin: 3% 0 0 0;" ] $ do
+    h1_ "500 INTERNAL SERVER ERROR"
+    p_  "This issue is probably our fault. \
+       \ Please try again shortly or contact us for help."