Support for Lucid HTML, add static file middleware

.gitignore

@@ -1,5 +1,6 @@
 WD
 bin/
+data
 /result
 /Dockerfile
 /docker-stack.yml

HELPS.cabal

@@ -25,10 +25,12 @@ common global
     , mtl
     , postgresql-simple
     , resource-pool
+    , servant-lucid
     , servant-server
     , text
     , time
     , utf8-string
+    , wai-middleware-static
     , warp
   default-extensions:
       BlockArguments
@@ -58,6 +60,7 @@ executable Main
     Handlers
     Logger
     Routes
+    Views
   build-depends: 
     HELPS
 
@@ -65,4 +68,4 @@ library
   import: global
   hs-source-dirs:
     src
-  exposed-modules: Core, Database, Handlers, Logger, Routes
+  exposed-modules: Core, Database, Handlers, Logger, Routes, Views, Main

src/Core.hs

@@ -15,6 +15,7 @@ import Effectful.Error.Static               (Error, throwError)
 import Effectful.Reader.Static              (Reader)
 import GHC.Generics                         (Generic)
 import Servant hiding                       ((:>), throwError)
+import Servant.HTML.Lucid
 
 --
 -- Core data types

src/Database.hs

@@ -4,6 +4,7 @@ import Core
 
 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
@@ -91,9 +92,9 @@ runDatabaseDebug = interpret $ \_ -> \case
      ++ "\nValues:\n"
      ++ show values
 
-createConnectionPool :: IO (Pool Connection)
+createConnectionPool :: ByteString -> IO (Pool Connection)
-createConnectionPool = newPool $ defaultPoolConfig
+createConnectionPool connectString = newPool $ defaultPoolConfig
-  (connectPostgreSQL "host=localhost dbname=demo")
+  (connectPostgreSQL connectString)
   close
   60
   10

src/Handlers.hs

@@ -3,26 +3,35 @@ 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 )
 
+-- Remember to drop effect constraints you don't need!
 rootHandler :: (Logger :> es, Error ServerError :> es)
-            => Eff es T.Text
+            => Eff es (Html ())
-rootHandler = (writeLog Info "Hit the root!") >>= \_ ->
+rootHandler = (writeLog Info "Hit the root!")
-  return "Hello, World!"
+    >>= \_ -> return V.root
 
 userListHandler :: CRUD es 
-                => Eff es [User]
+                => Eff es (Html ())
-userListHandler = (writeLog Info "Selected all users!") >>= \_ ->
+userListHandler = do
-  databaseRead_ "SELECT id, name FROM users"
+  writeLog Info "Selected all users!"
+  users <- databaseRead_ "SELECT id, name FROM users"
+  return $ V.baseDoc $ case users of
+    [] -> warning "No users found"
+    _  -> foldMap userHtml users
 
 userGetHandler :: CRUD es 
                => UserId -> Eff es User

src/Main.hs

@@ -6,24 +6,25 @@ 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)
+import qualified Servant             as S
 
 --
 -- Application
 --
 main :: IO ()
 main = do
-  pool   <- createConnectionPool 
+  pool   <- createConnectionPool "host=localhost dbname=demo"
   let env = AppEnv { pool = pool }
   runAppEff env $ databaseInit
-  run port . serve proxy $ app env
+  run port . middleware . serve proxy $ app env
 
 app :: AppEnv -> Server AppAPI
 app env = hoistServer proxy (Handler . ExceptT . runAppEff env) handlers
@@ -35,6 +36,9 @@ handlers = rootHandler
       :<|> userPostHandler
       :<|> userDeleteHandler
 
+middleware :: Application -> Application
+middleware = staticPolicy (noDots >-> addBase "data/assets/public")
+
 runAppEff :: AppEnv -> AppEff a -> IO (Either ServerError a)
 runAppEff env = runEff
               . runErrorNoCallStack

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/Views.hs

@@ -0,0 +1,34 @@
+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)