start base api

hastl.cabal

@@ -24,6 +24,9 @@ library
       , Models
       , Api
       , Api.User
+      , Api.Base
+      , Api.Templates.User
+      , Api.Templates.Base.Footer
       , Logger
       , DevelMain
     -- other-modules:

lib/Api.hs

@@ -5,7 +5,6 @@ module Api (app) where
 
 import Control.Monad.Reader (runReaderT)
 import Servant (
-  MimeRender,
   Proxy (Proxy),
   Raw,
   serveDirectoryFileServer,
@@ -15,7 +14,6 @@ import Servant.Server
 
 import Api.User (UserAPI, userApi, userServer)
 import Config (AppT (..), Config (..))
-import Lucid (ToHtml)
 
 {- | This functions tells Servant how to run the 'App' monad with our
 'server' function.
@@ -31,7 +29,7 @@ convertApp :: Config -> AppT IO a -> Handler a
 convertApp cfg appt = Handler $ runReaderT (runApp appt) cfg
 
 {- | Since we also want to provide a minimal front end, we need to give
-Servant a way to serve a directory with HTML and JavaScript. This
+Servant a way to serve a directory with HTML and CSS. This
 function creates a WAI application that just serves the files out of the
 given directory.
 -}

lib/Api/Base.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Api.Base where
+
+import Lucid (Html, body_, charset_, doctypehtml_, head_, href_, link_, meta_, rel_, title_, type_)
+
+import Servant (
+  Capture,
+  Get,
+  HasServer (ServerT),
+  JSON,
+  Post,
+  Proxy (..),
+  ReqBody,
+  err404,
+  throwError,
+  type (:<|>) (..),
+  type (:>),
+ )
+
+import Api.Templates.Base.Footer (renderFooter)
+import Servant.API.ContentTypes.Lucid (HTML)
+
+{- | The base template for all pages.
+This function takes the title of the page and the body of the page.
+It returns a full HTML document.
+The body of the page should be an HTML fragment.
+-}
+baseTemplate :: Html () -> Html () -> Html ()
+baseTemplate title' body' = do
+  doctypehtml_ $ do
+    head_ $ do
+      meta_ [charset_ "utf-8"]
+      title_ title'
+      link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.min.css"]
+    body_ $ do
+      body'
+      renderFooter
+
+type BaseAPI = "/base" :> Get '[HTML] (Html ())

lib/Api/Templates/Base/Footer.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Api.Templates.Base.Footer where
+
+import Lucid (Html, class_, div_, p_)
+
+renderFooter :: Html ()
+renderFooter = div_ [class_ "footer"] (p_ "This is the footer")

lib/Api/Templates/User.hs

@@ -1 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Api.Templates.User where
+
+import Models (User (userName))
+import Lucid (Html, div_, class_, p_, ToHtml (toHtml))
+
+renderUsers :: [User] -> Html () 
+renderUsers [] = div_ [class_ "users"] (p_ "No data")
+renderUsers users = div_ [class_ "users"] (do mapM_ renderUser users) 
+  where renderUser user = p_ (toHtml (userName user))
+

lib/Api/User.hs

@@ -31,29 +31,30 @@ import Servant (
 
 import Config (AppT (..))
 import Data.Text (Text)
-import Lucid (Html, ToHtml (toHtml), class_, div_, p_)
+import Lucid (Html)
 import Servant.API.ContentTypes.Lucid ( HTML )
 import Models (User (User), runDb, userEmail, userName)
 import Models qualified as Md
+import Api.Templates.User (renderUsers)
 
 type UserAPI =
-  "users" :> Get '[JSON] [Entity User]
+  "users" :> Get '[HTML] (Html ())
     :<|> "users" :> Capture "name" Text :> Get '[JSON] (Entity User)
     :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] Int64
-    :<|> "usersTable" :> Get '[HTML] (Html ())
 
 userApi :: Proxy UserAPI
 userApi = Proxy
 
 -- | The server that runs the UserAPI
 userServer :: (MonadIO m) => ServerT UserAPI (AppT m)
-userServer = allUsers :<|> singleUser :<|> createUser :<|> allUsersTbl
+userServer = allUsers :<|> singleUser :<|> createUser
 
 -- | Returns all users in the database.
-allUsers :: (MonadIO m) => AppT m [Entity User]
+allUsers :: (MonadIO m) => AppT m (Html ())
 allUsers = do
   logDebugNS "web" "allUsers"
-  runDb (selectList [] [])
+  users :: [Entity User] <- runDb (selectList [] [])
+  return $ renderUsers (map entityVal users)
 
 -- | Returns a user by name or throws a 404 error.
 singleUser :: (MonadIO m) => Text -> AppT m (Entity User)
@@ -72,11 +73,3 @@ createUser p = do
   logDebugNS "web" "creating a user"
   newUser <- runDb (insert (User (userName p) (userEmail p)))
   return $ fromSqlKey newUser
-
-allUsersTbl :: (MonadIO m) => AppT m (Html ())
-allUsersTbl = do
-  users :: [Entity User] <- runDb (selectList [] [])
-  return $
-    div_ [class_ ""] (do (mapM_ f users))
-  where f (Entity _ u) = p_ (toHtml (userName u))
-

static/index.html

@@ -9,7 +9,7 @@
       <h1 class="text-3xl font-bold underline">hastl</h1>
       <hr />
       Modern web application framework
-  <button hx-get="/usersTable" hx-swap="outerHTML">
+  <button hx-get="/users" hx-swap="outerHTML">
     Click Me
   </button>
     </div>