Playing with HTMX

Htmx.hs

{-# LANGUAGE ExtendedDefaultRules #-}
{- cabal:
build-depends: base, wai, warp, lucid, http-types, text, bytestring
-}
{-# LANGUAGE OverloadedStrings #-}

import Data.ByteString (ByteString)
import Data.Text (Text, intercalate)
import Data.Text.Encoding (decodeUtf8)
import Lucid (Attribute, Html, ToHtml (toHtml), renderBS)
import Lucid.Base (makeAttribute)
import Lucid.Html5
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Handler.Warp

err404 :: [Text] -> Response
err404 path =
  sendError status404 (p_ . toHtml $ "Could not find " <> intercalate "/" path)

sendHtml :: Html () -> Response
sendHtml = responseLBS status200 [("Content-Type", "text/html")] . renderBS

sendError :: Status -> Html () -> Response
sendError s b = responseLBS s [("Content-Type", "text/html")] . renderBS $
  html_ $ do
    head_ (title_ "Uh oh")
    body_ $ do
      h1_ "Something went wrong"
      b

greeting :: Text -> Html ()
greeting name = html_ $ do
  head_ (title_ . toHtml $ "Hello " <> name)
  body_ $ do
    p_ $ mkGreeting name
  where
    mkGreeting :: Text -> Html ()
    mkGreeting "Gideon" = "ERMERGERD!"
    mkGreeting "gideon" = "ermergerd!"
    mkGreeting n = toHtml $ "Hi there, " <> n

hxGet :: Text -> Attribute
hxGet = makeAttribute "hx-get"

hxTarget :: Text -> Attribute
hxTarget = makeAttribute "hx-target"

hxSwap :: Text -> Attribute
hxSwap = makeAttribute "hx-swap"

hxInclude :: Text -> Attribute
hxInclude = makeAttribute "hx-include"

hxParams :: [Text] -> Attribute
hxParams = makeAttribute "hx-include" . intercalate ","

indexPage :: Html ()
indexPage = html_ $ do
  head_ (title_ "Let's play with HTMX")
  body_ $ do
    h1_ "Let's play with HTMX!"
    p_ [style_ "italic"] "Because HYPERMEDIA R KOOL"
    div_ [id_ "greetings"] $ do
      h2_ "Getting to know each other"
      form_
        [ hxGet "/greet",
          hxInclude "find input",
          hxTarget "#greetings",
          hxSwap "outerHtml"
        ]
        $ do
          input_ [id_ "name-field", name_ "name", placeholder_ "So, what's your name?"]
          button_ "SAY MY NAME!"
    script_
      [ src_ "https://unpkg.com/htmx.org@1.9.10",
        integrity_ "sha384-D1Kt99CQMDuVetoL1lrYwg5t+9QdHe7NLX/SoJYkXDFfX37iInKRy5xLSi8nO7UC",
        crossorigin_ "anonymous"
      ]
      (mempty :: Html ())

routes :: Application
routes req res = case pathInfo req of
  ["greet"] -> case getQuery "name" $ queryString req of
    Just n -> res . sendHtml $ greeting n
    Nothing -> res . sendError status400 $ "Missing input"
  [] -> res . sendHtml $ indexPage
  p -> res $ err404 p
  where
    getQuery :: ByteString -> Query -> Maybe Text
    getQuery q [] = Nothing
    getQuery q ((n, v) : rest)
      | n == q = decodeUtf8 <$> v
      | otherwise = getQuery q rest

main :: IO ()
main = do
  putStrLn "Running on 2712"
  run 2712 routes