Compare commits

..

No commits in common. "691e51660f2e87ed2ce778da92ef000db6b31654" and "a7836ad08f70512e07e829c0fed8d2718c1a42df" have entirely different histories.

13 changed files with 201 additions and 390 deletions

14
.gitignore vendored
View File

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

View File

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

View File

@ -8,29 +8,4 @@ A work in progress Nix starting template for web projects utilizing
- [PostgreSQL](https://www.postgresql.org/) - [PostgreSQL](https://www.postgresql.org/)
- [Servant](https://github.com/haskell-servant/servant) - [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, write/compose HTML using Lucid, 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, 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

View File

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

View File

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

View File

@ -1,5 +1,7 @@
module Core where module Core where
import Control.Exception (IOException)
import Control.Monad.Catch (catch)
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
import Data.Pool (Pool) import Data.Pool (Pool)
import qualified Data.Text as T import qualified Data.Text as T
@ -9,43 +11,41 @@ import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
import Database.PostgreSQL.Simple.ToField (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
import Effectful.Error.Static (Error) import Effectful.Error.Static (Error, throwError)
import Effectful.Reader.Static (Reader) import Effectful.Reader.Static (Reader)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Servant hiding ((:>)) import Servant hiding ((:>), throwError)
import Servant.HTML.Lucid
-- --
-- Core data types -- Core data types
-- --
type AppEff = type AppEff = Eff '[ Logger
Eff '[ Logger
, Database , Database
, Reader AppEnv , Reader AppEnv
, Error ServerError , Error ServerError
, IOE
] ]
data AppEnv = AppEnv { pool :: Maybe (Pool Connection) } data AppEnv = AppEnv { pool :: Pool Connection }
newtype UserId = UserId Int newtype UserId = UserId Int
deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData) deriving (Show, Generic, FromField, ToField, FromHttpApiData, ToHttpApiData)
data User = User { userId :: UserId, userName :: T.Text}
deriving (Show, Generic)
instance ToJSON UserId instance ToJSON UserId
instance FromJSON UserId instance FromJSON UserId
instance ToRow UserId instance ToRow UserId
instance FromRow UserId instance FromRow UserId
instance ToJSON User data User = User { userId :: UserId, userName :: T.Text}
instance FromJSON User deriving (Show, Generic)
instance ToRow User where
toRow (User uid name) = toRow (uid, name)
instance FromRow User where instance FromRow User where
fromRow = User <$> field <*> field fromRow = User <$> field <*> field
instance ToRow User where
toRow (User uid name) = toRow (uid, name)
instance ToJSON User
instance FromJSON User
data Database :: Effect where data Database :: Effect where
DatabaseInit DatabaseInit
@ -65,3 +65,17 @@ data LogLevel = Info | Warning | Error
instance ToField LogLevel where instance ToField LogLevel where
toField level = toField (T.pack (show level)) 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 = []
}

View File

@ -1,15 +1,12 @@
module Database where module Database where
import Core import Core
import Utility
import Control.Exception (IOException) import Control.Exception (IOException)
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import Data.ByteString (ByteString)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Data.Pool 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
import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.ToField (ToField)
import Effectful import Effectful
@ -26,73 +23,25 @@ type DatabaseExeEffects es = ( Reader AppEnv :> es
, IOE :> es , IOE :> es
) )
databaseInit :: (Database :> es, Error ServerError :> es) databaseInit
=> Eff es () :: (Database :> es, Error ServerError :> es) => Eff es ()
databaseInit = send DatabaseInit databaseInit = send DatabaseInit
databaseRead :: (ToField a, Show a, Database :> es, Error ServerError :> es) databaseRead
:: (ToField a, Show a, Database :> es, Error ServerError :> es)
=> (Query, a) -> Eff es [User] => (Query, a) -> Eff es [User]
databaseRead = send . DatabaseRead databaseRead = send . DatabaseRead
databaseRead_ :: (Database :> es, Error ServerError :> es) databaseRead_
=> Query -> Eff es [User] :: (Database :> es, Error ServerError :> es) => Query -> Eff es [User]
databaseRead_ = send . DatabaseRead_ databaseRead_ = send . DatabaseRead_
databaseWrite :: (ToRow a, Show a, Database :> es, Error ServerError :> es) databaseWrite
:: (ToRow a, Show a, Database :> es, Error ServerError :> es)
=> (Query, a) -> Eff es () => (Query, a) -> Eff es ()
databaseWrite = send . DatabaseWrite databaseWrite = send . DatabaseWrite
runDatabaseIO :: DatabaseExeEffects es runDatabaseDebug :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
=> 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 runDatabaseDebug = interpret $ \_ -> \case
DatabaseInit -> do DatabaseInit -> do
liftIOE $ putStrLn "Mocked setup of the database" liftIOE $ putStrLn "Mocked setup of the database"
@ -100,7 +49,7 @@ runDatabaseDebug = interpret $ \_ -> \case
liftIOE $ putStrLn liftIOE $ putStrLn
$ "Mocked a READ database operation with statement:\n" $ "Mocked a READ database operation with statement:\n"
++ show statement ++ show statement
++ "\nValues:\n" ++ " and values:\n"
++ show values ++ show values
pure [] pure []
DatabaseRead_ statement -> do DatabaseRead_ statement -> do
@ -108,14 +57,48 @@ runDatabaseDebug = interpret $ \_ -> \case
pure [] pure []
DatabaseWrite (statement, values) -> do DatabaseWrite (statement, values) -> do
liftIOE $ putStrLn liftIOE $ putStrLn
$ "Mocked a WRITE database operation with statement:\n" $ "Mocked a WRITE database operation with a user named " ++ show values
++ show statement
++ "\nValues:\n"
++ show values
createConnectionPool :: ByteString -> IO (Pool Connection) runDatabaseIO :: DatabaseExeEffects es => Eff (Database : es) a -> Eff es a
createConnectionPool connectString = newPool $ defaultPoolConfig runDatabaseIO = interpret $ \_ -> \case
(connectPostgreSQL connectString) 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
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 close
60 60
10 10
@ -129,14 +112,14 @@ writeUser name = ("INSERT INTO users (name) VALUES (?);", Only name)
deleteUser :: UserId -> (Query, UserId) deleteUser :: UserId -> (Query, UserId)
deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId) deleteUser userId = ("DELETE FROM users WHERE id = ?;", userId)
createUsersTable :: Query tableUsers :: Query
createUsersTable = "CREATE TABLE IF NOT EXISTS users ( \ tableUsers = "CREATE TABLE IF NOT EXISTS users ( \
\ id SERIAL PRIMARY KEY, \ \id integer NOT NULL, \
\name character varying(255) NOT NULL \ \name character varying(255) NOT NULL \
\);" \);"
createLogsTable :: Query tableLogs :: Query
createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \ tableLogs = "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, \
@ -144,11 +127,3 @@ createLogsTable = "CREATE TABLE IF NOT EXISTS logs ( \
\ 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

View File

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

View File

@ -2,7 +2,6 @@ module Logger where
import Core import Core
import Database import Database
import Utility
import Data.Time (getCurrentTime, UTCTime) import Data.Time (getCurrentTime, UTCTime)
import Effectful import Effectful
@ -20,8 +19,8 @@ writeLog :: (Logger :> es, Error ServerError :> es)
=> LogLevel -> String -> Eff es () => LogLevel -> String -> Eff es ()
writeLog level msg = send (WriteLog level msg) 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 runLoggerConsole = interpret $ \_ -> \case
WriteLog level msg -> do WriteLog level msg -> do
time <- liftIOE getCurrentTime time <- liftIOE getCurrentTime
@ -30,9 +29,19 @@ runLoggerConsole = interpret $ \_ -> \case
++ "LEVEL: " ++ show level ++ "\n" ++ "LEVEL: " ++ show level ++ "\n"
++ "MESSAGE: " ++ msg ++ "MESSAGE: " ++ msg
runLoggerPSQL :: LogToDatabase es runLoggerPSQL :: LogToDatabase es => Eff (Logger : es) a -> Eff es a
=> Eff (Logger : es) a -> Eff es a
runLoggerPSQL = interpret $ \_ -> \case runLoggerPSQL = interpret $ \_ -> \case
WriteLog level msg -> WriteLog level msg ->
databaseWrite databaseWrite
("INSERT INTO logs (level, message) VALUES (?,?);", (level, msg)) ("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
);
-}

View File

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

View File

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

View File

@ -1,31 +0,0 @@
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 = []
}

View File

@ -1,41 +0,0 @@
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."