implement HX-Retarget error handling

eldr-io · Jun 8, 2024 · 36ce112 · 36ce112
1 parent fac2f6d
commit 36ce112
Show file tree

Hide file tree

Showing 14 changed files with 250 additions and 67 deletions.
diff --git a/hastl.cabal b/hastl.cabal
@@ -28,6 +28,8 @@ library
       , Api.Templates.User.User
       , Api.Templates.Base.Footer
       , Api.Templates.Base.Header
+      , Api.Templates.Base.Home
+      , Api.Templates.Base.About
       , Api.Templates.Helpers.Htmx
       , Api.Templates.Helpers.Alpine
       , Api.Templates.Helpers.Icons
@@ -60,6 +62,7 @@ library
       , dani-servant-lucid2
       , text
       , transformers
+      , time
       , unordered-containers
       , wai
       , wai-extra

diff --git a/lib/Api/Base.hs b/lib/Api/Base.hs
@@ -1,81 +1,79 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Api.Base where
 
 import Lucid (
   Html,
   a_,
-  b_,
   body_,
   br_,
   class_,
   div_,
   doctypehtml_,
   h1_,
   href_,
+  id_,
   p_,
-  script_,
-  src_,
   target_,
  )
 import Servant (
   Get,
   HasServer (ServerT),
   Proxy (..),
+  (:<|>),
+  (:>),
+  type (:<|>) (..),
  )
 
+import Api.Templates.Base.About (renderAbout)
 import Api.Templates.Base.Footer (renderFooter)
 import Api.Templates.Base.Header (renderBanner, renderHeader, renderNavigation)
+import Api.Templates.Base.Home (renderHome)
 import Api.Templates.Helpers.Alpine (useAlpine)
-import Api.Templates.Helpers.Htmx (hxGet_, hxSwap_, hxTrigger_, useHtmxJsExt, useHtmxVersion)
-import Api.Templates.User.User (renderAddUserForm)
+import Api.Templates.Helpers.Htmx (useHtmxJsExt, useHtmxVersion)
 import Config (AppT)
 import Control.Monad.Cont (MonadIO)
+import Data.Text (Text)
 import Servant.API.ContentTypes.Lucid (HTML)
 
-baseTemplate :: Html () -> Html () -> Html ()
-baseTemplate title content = do
+baseTemplate :: Html () -> Text -> Html () -> Html ()
+baseTemplate title pageName content = do
   doctypehtml_ $ do
     renderHeader title
     body_ $ do
       renderBanner
-      renderNavigation
+      renderNavigation pageName
+      div_ [id_ "errors", class_ "max-w-screen-xl mx-auto"] mempty
       content
       renderFooter
       useHtmxVersion (1, 9, 12)
       useHtmxJsExt
       useAlpine
 
-type BaseAPI = Get '[HTML] (Html ())
+type BaseAPI =
+  Get '[HTML] (Html ())
+    :<|> "about" :> Get '[HTML] (Html ())
 
 baseApi :: Proxy BaseAPI
 baseApi = Proxy
 
 -- | The server that runs the UserAPI
 baseServer :: (MonadIO m) => ServerT BaseAPI (AppT m)
-baseServer = base
+baseServer = base :<|> about
+
+about :: (MonadIO m) => AppT m (Html ())
+about =
+  return $
+    baseTemplate
+      "Hastl | About"
+      "About"
+      renderAbout
 
 base :: (MonadIO m) => AppT m (Html ())
 base =
   return $
     baseTemplate
-      "hastl"
-      ( div_ [class_ "mt-4"] $ do
-          div_ [class_ "max-w-screen-xl mx-auto"] $ do
-            h1_ [class_ "text-3xl font-bold text-gray-900"] "Welcome to hastl"
-            p_ [class_ "text-gray-600"] $ do
-              "hastl is a modern "
-              a_ [href_ "haskell.org", target_ "_blank"] "Haskell"
-              " web application using "
-              b_ "(H)tmx, "
-              b_ "(A)lpine.js, "
-              b_ "(S)ervant, "
-              b_ "(T)ailwind-css "
-              "and"
-              b_ "(L)ucid. "
-              "It is licensed under MIT and is entirely free and open source."
-            br_ []
-            p_ [class_ "text-gray-600"] "Try it out below by adding guests to your awesome party!"
-            renderAddUserForm
-          div_ [hxGet_ "/users", hxSwap_ "innerHTML", hxTrigger_ "load"] $ p_ "Loading..."
-      )
+      "Hastl | Modern Haskell Web Application Starter Kit"
+      "Home"
+      renderHome
diff --git a/lib/Api/Templates/Base/About.hs b/lib/Api/Templates/Base/About.hs
@@ -0,0 +1,31 @@
+module Api.Templates.Base.About where
+
+import Api.Templates.Base.Home (renderBadges)
+import Lucid
+
+renderAbout :: Html ()
+renderAbout =
+  div_ [class_ "mt-4"] $ do
+    div_ [class_ "max-w-screen-xl mx-auto"] $ do
+      h1_ [class_ "text-xl font-bold text-gray-900"] "About"
+      p_ [class_ "text-gray-600 mt-1"] $ do
+        "hastl is a modern Haskell web application using Htmx, Alpine.js, Servant,"
+        "Tailwind-css and Lucid. It is licensed under MIT and is entirely free and open source."
+        br_ []
+        br_ []
+        "This is a simple about page, showing one of the features of the hastl template, routing."
+        "Hastl allows you to split your application into multiple strongly typed Servant API's and combine different endpoints that return either JSON, raw HTML or HTMX-enabled hypermedia."
+        br_ []
+        br_ []
+        "Additionally, hastl provides tooling to auto-reload your server on changes and recompile your tailwindcss stylesheets automatically, giving you a fast feedback loop. "
+        "Check out "
+        a_ [href_ "https://github.com/eldr-io/hastl", target_ "_blank"] "the hastl docs"
+        " for more information."
+        br_ []
+        br_ []
+        b_ "hastl was built on top of the awesome servant-persistant example by Matt Parsons, so be sure to "
+        a_ [href_ "https://github.com/parsonsmatt/servant-persistent", target_ "_blank"] "check it out"
+        "!"
+        div_ [class_ "mt-5"] $ do
+          h2_ [class_ "text-md font-bold text-gray-900"] "Built with:"
+          renderBadges
diff --git a/lib/Api/Templates/Base/Footer.hs b/lib/Api/Templates/Base/Footer.hs
@@ -2,7 +2,13 @@
 
 module Api.Templates.Base.Footer where
 
-import Lucid (Html, class_, div_, p_)
+import Lucid (Html, a_, class_, div_, href_, p_)
 
 renderFooter :: Html ()
-renderFooter = div_ [class_ "footer"] (p_ "This is the footer")
+renderFooter =
+  div_
+    [class_ "absolute inset-x-0 bottom-0 max-w-screen-lg text-center mx-auto footer text-gray-500 mb-5 text-sm"]
+    ( p_ $ do
+        "hastl - modern haskell web app template coded with <3 by "
+        a_ [href_ "https://eldr.io"] "eldr.io"
+    )
diff --git a/lib/Api/Templates/Base/Header.hs b/lib/Api/Templates/Base/Header.hs
@@ -3,6 +3,7 @@ module Api.Templates.Base.Header where
 import Api.Templates.Helpers.Alpine
 import Api.Templates.Helpers.Htmx
 import Api.Templates.Helpers.Icons (iconChevronDown_, iconGithub_)
+import Data.Text (Text)
 import Lucid
 
 renderHeader :: Html () -> Html ()
@@ -42,7 +43,7 @@ renderBanner = do
             [ class_ "text-sm leading-6 text-gray-900"
             ]
             $ do
-              strong_ [class_ "font-semibold"] "hastl is built with haskell and is entirely free and open source"
+              strong_ [class_ "font-semibold"] "λ hastl is built with haskell and is entirely free and open source"
               svg_
                 [ viewBox_ "0 0 2 2"
                 , class_ "mx-2 inline h-0.5 w-0.5 fill-current"
@@ -90,11 +91,19 @@ renderDropdownBtn = do
         , class_ "w-full absolute top-12 left-0 p-2 bg-white border border-gray-200 rounded-lg shadow"
         ]
         $ do
-          div_ [class_ "px-2 py-1 cursor-pointer hover:bg-sky-100 rounded-lg"] "First item"
-          div_ [class_ "px-2 py-1 cursor-pointer hover:bg-sky-100 rounded-lg"] "Second item"
+          div_
+            [ xOn_ "click" "window.open('https://github.com/eldr-io/hastl', '_blank').focus();"
+            , class_ "px-2 py-1 cursor-pointer hover:bg-sky-100 rounded-lg"
+            ]
+            "Github"
+          div_
+            [ xOn_ "click" "window.open('https://github.com/eldr-io/hastl/blob/main/README.md', '_blank').focus();"
+            , class_ "px-2 py-1 cursor-pointer hover:bg-sky-100 rounded-lg"
+            ]
+            "Documentation"
 
-renderNavigation :: Html ()
-renderNavigation = do
+renderNavigation :: Text -> Html ()
+renderNavigation activeItem = do
   nav_ [class_ "bg-white border-gray-200 py-2.5 dark:bg-gray-900"] $ do
     div_ [class_ "flex flex-wrap items-center justify-between max-w-screen-xl px-4 mx-auto"] $ do
       a_ [href_ "/", class_ "flex items-center"] $ do
@@ -104,5 +113,10 @@ renderNavigation = do
         renderDropdownBtn
       div_ [class_ "items-center justify-between w-full lg:flex lg:w-auto lg:order-1", id_ "mobile-menu-2"] $ do
         ul_ [class_ "flex flex-col mt-4 font-medium lg:flex-row lg:space-x-8 lg:mt-0"] $ do
-          li_ $ a_ [href_ "/", class_ "block py-2 pl-3 pr-4 text-white bg-purple-700 rounded lg:bg-transparent lg:text-purple-700 lg:p-0 dark:text-white", ariaCurrent_ "page"] "Home"
-          li_ $ a_ [href_ "/about", hxBoost_ "true", class_ "block py-2 pl-3 pr-4 text-gray-700 border-b border-gray-100 hover:bg-gray-50 lg:hover:bg-transparent lg:border-0 lg:hover:text-purple-700 lg:p-0 dark:text-gray-400 lg:dark:hover:text-white dark:hover:bg-gray-700 dark:hover:text-white lg:dark:hover:bg-transparent dark:border-gray-700"] "About"
+          mapM_ renderNavigationItem [("/", "Home", activeItem == "Home"), ("/about", "About", activeItem == "About")]
+
+renderNavigationItem :: (Text, Text, Bool) -> Html ()
+renderNavigationItem (href, text, False) = do
+  li_ $ a_ [href_ href, class_ "block py-2 pl-3 pr-4 text-gray-700 border-b border-gray-100 hover:bg-gray-50 lg:hover:bg-transparent lg:border-0 lg:hover:text-purple-700 lg:p-0 dark:text-gray-400 lg:dark:hover:text-white dark:hover:bg-gray-700 dark:hover:text-white lg:dark:hover:bg-transparent dark:border-gray-700"] (toHtml text)
+renderNavigationItem (href, text, True) = do
+  li_ $ a_ [href_ href, class_ "block py-2 pl-3 pr-4 text-white bg-purple-700 rounded lg:bg-transparent lg:text-purple-700 lg:p-0 dark:text-white"] (toHtml text)
diff --git a/lib/Api/Templates/Base/Home.hs b/lib/Api/Templates/Base/Home.hs
@@ -0,0 +1,40 @@
+module Api.Templates.Base.Home where
+
+import Api.Templates.Helpers.Htmx
+import Api.Templates.User.User (renderAddUserForm)
+import Lucid
+
+renderHome :: Lucid.Html ()
+renderHome =
+  div_ [class_ "mt-4"] $ do
+    div_
+      [class_ "max-w-screen-xl mx-auto"]
+      $ do
+        h1_ [class_ "text-3xl font-bold text-gray-900"] "Welcome to hastl"
+        p_ [class_ "text-gray-600"] $ do
+          "hastl is a modern "
+          a_ [href_ "haskell.org", target_ "_blank"] "Haskell"
+          " web application using "
+          b_ "(H)tmx, "
+          b_ "(A)lpine.js, "
+          b_ "(S)ervant, "
+          b_ "(T)ailwind-css "
+          "and"
+          b_ "(L)ucid. "
+          "It is licensed under MIT and is entirely free and open source."
+        br_ []
+        renderBadges
+        p_ [class_ "text-gray-600 mt-5"] "Try it out below by adding guests to your awesome party!"
+        renderAddUserForm
+        p_ [class_ "text-xs text-gray-500 mt-2 mx-auto text-center"] "* Don't worry, we won't actually send anything!"
+    div_ [hxGet_ "/users", hxSwap_ "innerHTML", hxTrigger_ "load"] $ p_ "Loading..."
+
+renderBadges :: Html ()
+renderBadges =
+  div_ [class_ "mx-auto max-w-screen-xl"] $ do
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/haskell-5D4F85?style=for-the-badge&logo=haskell&logoColor=white"]
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/htmxjs-3366CC?style=for-the-badge&logo=htmx&logoColor=white"]
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/alpinejs-8BC0D0?style=for-the-badge&logo=alpine.js&logoColor=white"]
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/Servant-5D4F85?style=for-the-badge&logo=haskell&logoColor=white"]
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/Tailwind-06B6D4?style=for-the-badge&logo=tailwindcss&logoColor=white"]
+    img_ [class_ "col-span-1 inline", src_ "https://img.shields.io/badge/Lucid-5D4F85?style=for-the-badge&logo=haskell&logoColor=white"]
diff --git a/lib/Api/Templates/Helpers/Htmx.hs b/lib/Api/Templates/Helpers/Htmx.hs
@@ -140,6 +140,12 @@ hxTrigger_ = makeAttributes "data-hx-trigger"
 hxVals_ :: Text -> Attributes
 hxVals_ = makeAttributes "data-hx-vals"
 
+hxTarget500_ :: Text -> Attributes
+hxTarget500_ = makeAttributes "data-hx-target-500"
+
+hxTargetError_ :: Text -> Attributes
+hxTargetError_ = makeAttributes "data-hx-target-error"
+
 -- | <https://htmx.org/attributes/hx-ws/>
 hxWs_ :: Text -> Attributes
 hxWs_ = makeAttributes "data-hx-ws"
@@ -203,6 +209,9 @@ useHtmxVersion semVer = script_ [defer_ "", src_ $ htmxSrcWithSemVer semVer] (""
 useHtmxJsExt :: (Monad m) => HtmlT m ()
 useHtmxJsExt = script_ [defer_ "", src_ "https://unpkg.com/[email protected]/dist/ext/json-enc.js"] ("" :: Html ())
 
+useHtmxRetargetErrorsExt :: (Monad m) => HtmlT m ()
+useHtmxRetargetErrorsExt = script_ [defer_ "", src_ "https://unpkg.com/[email protected]/dist/ext/response-targets.js"] ("" :: Html ())
+
 htmxSrc :: Text
 htmxSrc = "https://unpkg.com/htmx.org"
 

diff --git a/lib/Api/Templates/User/User.hs b/lib/Api/Templates/User/User.hs
@@ -10,23 +10,38 @@ import Lucid
 import Models (User (userName))
 
 renderAddUserForm :: Html ()
-renderAddUserForm =
+renderAddUserForm = do
+  div_ [id_ "form-errors", class_ ""] mempty
   div_
     [ id_ "add-user-form"
-    , class_ "add-user-form bg-white shadow-md rounded-md overflow-hidden max-w-lg mx-auto mt-16"
+    , class_ "add-user-form shadow-md rounded-md overflow-hidden max-w-fit mx-auto mt-16"
     ]
     $ do
       div_ [class_ "bg-gray-100 px-4 py-2"] $ p_ "Add a Party Animal"
-      form_ [hxPost_ "/users", hxTarget_ "#users-ul", hxSwap_ "beforeend transition:true", hxExt_ "json-enc"] $ do
-        input_ [class_ "w-full px-4 py-2 border border-gray-200 rounded-md", type_ "text", name_ "name", placeholder_ "Name"]
-        input_ [class_ "w-full px-4 py-2 border border-gray-200 rounded-md", type_ "email", name_ "email", placeholder_ "Email"]
-        button_ [class_ "w-full px-4 py-2 bg-blue-500 text-white rounded-md mt-2", type_ "submit"] "Add Party Animal"
+      form_ [hxPost_ "/users", hxTarget_ "#users-ul", hxSwap_ "afterbegin transition:true", hxExt_ "json-enc"] $ do
+        input_
+          [ class_ "w-full px-4 py-2 border border-gray-200 rounded-md"
+          , type_ "text"
+          , name_ "name"
+          , placeholder_ "Name"
+          ]
+        input_
+          [ class_ "w-full px-4 py-2 border border-gray-200 rounded-md"
+          , type_ "email"
+          , name_ "email"
+          , placeholder_ "Email"
+          ]
+        button_
+          [ class_ "w-full px-4 py-2 bg-primary hover:bg-violet-500 text-white rounded-md mt-2"
+          , type_ "submit"
+          ]
+          "Invite to your party"
 
 renderUsersComponent :: [Entity User] -> Html ()
 renderUsersComponent users =
   div_
     [ id_ "users"
-    , class_ "users bg-white shadow-md rounded-md overflow-hidden max-w-lg mx-auto mt-16"
+    , class_ "users bg-white shadow-md rounded-md overflow-hidden max-w-xl mx-auto mt-14"
     ]
     $ do
       div_ [class_ "bg-gray-100 px-4 py-2"] $ p_ "Party Goers"
@@ -36,7 +51,7 @@ renderUser :: Entity User -> Html ()
 renderUser user = do
   let userId = show (fromSqlKey (entityKey user))
       name = userName (entityVal user)
-  li_ [class_ "flex items-center px-6 py-4"] $ do
+  li_ [class_ "flex items-center px-6 py-4 smooth"] $ do
     img_
       [ class_ "w-12 h-12 rounded-full object-cover mr-4"
       , src_ ("https://randomuser.me/api/portraits/women/" <> T.pack userId <> ".jpg")
@@ -47,7 +62,7 @@ renderUser user = do
       p_ [class_ "text-sm font-normal text-gray-600"] "Party Animal"
 
 renderUsers :: [Entity User] -> Html ()
-renderUsers [] = ul_ [id_ "users-ul", class_ "divide-y divide-gray-200"] $ li_ [] "No data"
+renderUsers [] = ul_ [id_ "users-ul", class_ "divide-y divide-gray-200"] $ li_ [] mempty
 renderUsers users = do
   ul_ [id_ "users-ul", class_ "divide-y divide-gray-200"] $ do
     mapM_ renderUser users