more better posts

app/Lib/Blaze.hs

@@ -11,7 +11,13 @@ import Text.Blaze.Html5.Attributes qualified as A
 import Web.Scotty (ActionM, raw, setHeader)
 
 classQQ :: QuasiQuoter
-classQQ = QuasiQuoter{quoteExp = \str -> [|A.class_ . fromString . unwords . words $ str|]}
+classQQ =
+  QuasiQuoter
+    { quoteExp = \str -> [|A.class_ . fromString . unwords . words $ str|]
+    , quotePat = error "not supported"
+    , quoteDec = error "not supported"
+    , quoteType = error "not supported"
+    }
 
 blazeHtml :: Html -> ActionM ()
 blazeHtml h = do

app/Lib/Database.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Lib.Database where
+
+import Control.Monad
+import Data.Maybe
+import Data.Text qualified as T
+import Database.MongoDB
+import Network.URI
+
+getDbInfo :: String -> (String, Username, Password)
+getDbInfo uri = fromJust $ do
+  parsed <- parseURI uri
+
+  guard $ uriScheme parsed == "mongodb+srv:"
+
+  uriAuth <- uriAuthority parsed
+
+  let (uname, pw) = T.breakOn ":" . T.pack $ uriUserInfo uriAuth
+
+  return (uriRegName uriAuth, uname, T.tail . T.init $ pw)
+
+getPipe :: ReplicaSet -> Username -> Password -> IO Pipe
+getPipe rs uname passwd = do
+  pipe <- primary rs
+  _ <- access pipe master admin (auth uname passwd)
+  return pipe

app/Main.hs

@@ -10,19 +10,23 @@ import Configuration.Dotenv
 import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
+import Data.Either
 import Data.Functor ((<&>))
 import Data.List (intersperse)
 import Data.Maybe
 import Data.Pool
 import Data.String (fromString)
 import Data.Text (Text)
-import Data.Text qualified as T
+import Data.Time.Clock
+import Data.Time.Format
+import Data.Time.Format.ISO8601
+import Data.Word
 import Database.MongoDB
 import Database.MongoDB qualified as M
 import GHC.Generics
 import Lib.Blaze
+import Lib.Database
 import Network.Socket as S
-import Network.URI
 import Network.Wai.Handler.Warp
 import Network.Wai.Middleware.RequestLogger
 import System.Directory
@@ -36,7 +40,7 @@ import Text.Pandoc (
   def,
   extensionsFromList,
   readMarkdown,
-  runIOorExplode,
+  runPure,
   writeHtml5,
  )
 import Web.Scotty
@@ -47,46 +51,49 @@ isDebug =
     Just "1" -> True
     _ -> False
 
-getDbInfo :: String -> (String, Username, Password)
-getDbInfo uri = fromJust $ do
-  parsed <- parseURI uri
-
-  guard $ uriScheme parsed == "mongodb+srv:"
-
-  uriAuth <- uriAuthority parsed
-
-  let (uname, pw) = T.breakOn ":" . T.pack $ uriUserInfo uriAuth
-
-  return (uriRegName uriAuth, uname, T.tail . T.init $ pw)
-
-getPipe :: ReplicaSet -> Username -> Password -> IO Pipe
-getPipe rs uname passwd = do
-  pipe <- primary rs
-  _ <- access pipe master admin (auth uname passwd)
-  return pipe
-
-mdToHtml :: Text -> IO Html
+mdToHtml :: Text -> Html
 mdToHtml =
-  runIOorExplode
+  fromRight mempty
+    . runPure
     . ( writeHtml5 def
           <=< readMarkdown def{readerExtensions = extensionsFromList [Ext_backtick_code_blocks]}
       )
 
-scottySocket' :: Maybe String -> Options -> ScottyM () -> IO ()
+scottySocket' :: Maybe FilePath -> Options -> ScottyM () -> IO ()
 scottySocket' mpath opts app = case mpath of
   Nothing -> do
     scottyOpts opts app
   Just p -> do
-    let cleanup = (>> removeFile p) . S.close
+    let cleanup s = do
+          S.close s
+          removeFile p
     bracket (socket AF_UNIX Stream 0) cleanup $ \sock -> do
       bind sock $ SockAddrUnix p
       listen sock maxListenQueue
       scottySocket opts sock app
 
+data Page = Page
+  { pageLimit :: Word32
+  , pageOffset :: Word32
+  }
+  deriving (Show, Eq)
+
+returnDefault :: a -> StatusError -> ActionM a
+returnDefault a = const (return a)
+
+getPage :: ActionM Page
+getPage = do
+  pageLimit <- queryParam "limit" `rescue` returnDefault 10
+  pageOffset <- queryParam "offset" `rescue` returnDefault 0
+
+  return Page{..}
+
 data Post = Post
   { postId :: ObjectId
   , postTitle :: Text
   , postBody :: Text
+  , postCreated :: UTCTime
+  , postUpdated :: UTCTime
   }
   deriving (Generic, Show, Eq)
 
@@ -102,13 +109,20 @@ instance FromDocument Post where
     postId = M.at "_id" d
     postTitle = M.at "title" d
     postBody = M.at "body" d
+    postCreated = M.at "created" d
+    postUpdated = M.at "updated" d
+
+timeEl :: (FormatTime t, ISO8601 t) => t -> Html
+timeEl t = do
+  H.time H.! A.datetime (fromString $ formatShow iso8601Format t) $
+    H.toHtml $
+      formatTime defaultTimeLocale "%c" t
 
-postHtml :: Post -> Html -> Html
-postHtml p pb = H.article
+postHtml :: Post -> Html
+postHtml p = H.article
   H.! [classQQ|
               prose
               prose-slate
-              prose-a:no-underline
               prose-a:bg-gradient-to-r
               prose-a:from-indigo-500
               prose-a:via-purple-500
@@ -117,12 +131,19 @@ postHtml p pb = H.article
               prose-a:bg-no-repeat
               prose-a:bg-underline
               hover:prose-a:bg-underline-hover
+              hover:prose-a:no-underline
               prose-a:transition-background-size
-              prose-a:font-black
+              prose-h1:mb-1
               |]
   $ do
-    H.h1 . H.toHtml $ postTitle p
-    pb
+    H.header $ do
+      H.h1 $ H.toHtml (postTitle p)
+      H.p H.! [classQQ| m-0 text-sm |] $ do
+        H.span H.! [classQQ| font-bold mx-1 |] $ "Created:"
+        timeEl (postCreated p)
+        H.span H.! [classQQ| font-bold mx-1 |] $ "Updated:"
+        timeEl (postUpdated p)
+    mdToHtml $ postBody p
 
 main :: IO ()
 main = do
@@ -155,19 +176,22 @@ main = do
         else logStdout
 
     get "/posts" $ do
-      ds <- liftIO $ withResource pool $ \p ->
-        access p master "blog" $
-          find (select ["published" =: True] "posts"){sort = ["updated" =: (-1 :: Int)]} >>= rest
-
-      posts <-
-        liftIO
-          ( forM ds $ \d -> do
-              let p = fromDocument d
-              pb <- mdToHtml $ postBody p
-              return $ postHtml p pb
-          )
-
-      blazeHtml . sequence_ $
-        intersperse
-          (H.div H.! A.class_ "divider" $ mempty)
-          posts
+      page <- getPage
+
+      docs <- liftIO . withResource pool $ \p -> do
+        access p slaveOk "blog" $
+          find
+            (select ["published" =: True] "posts")
+              { sort = ["updated" =: (-1 :: Int)]
+              , limit = pageLimit page
+              , skip = pageOffset page
+              }
+            >>= rest
+
+      let posts = map (postHtml . fromDocument) docs
+
+      blazeHtml $ do
+        sequence_ $
+          intersperse
+            (H.div H.! A.class_ "divider" $ mempty)
+            posts

haskell-blog.cabal

@@ -61,7 +61,8 @@ executable haskell-blog
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    other-modules:    Lib.Blaze
+    other-modules:    Lib.Blaze,
+                      Lib.Database
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -81,7 +82,9 @@ executable haskell-blog
                       network,
                       directory,
                       pandoc,
-                      template-haskell
+                      pandoc-types,
+                      template-haskell,
+                      time
 
     -- Directories containing source files.
     hs-source-dirs:   app

highlight.css

@@ -1,95 +1,3 @@
-/* CSS for syntax highlighting */
-pre > code.sourceCode {
-    white-space: pre;
-    position: relative;
-}
-
-pre > code.sourceCode > span {
-    line-height: 1.25;
-}
-
-pre > code.sourceCode > span:empty {
-    height: 1.2em;
-}
-
-.sourceCode {
-    overflow: visible;
-}
-
-code.sourceCode > span {
-    color: inherit;
-    text-decoration: inherit;
-}
-
-div.sourceCode {
-    margin: 1em 0;
-}
-
-pre.sourceCode {
-    margin: 0;
-}
-
-@media screen {
-    div.sourceCode {
-        overflow: auto;
-    }
-}
-
-@media print {
-    pre > code.sourceCode {
-        white-space: pre-wrap;
-    }
-
-    pre > code.sourceCode > span {
-        text-indent: -5em;
-        padding-left: 5em;
-    }
-}
-
-pre.numberSource code {
-    counter-reset: source-line 0;
-}
-
-pre.numberSource code > span {
-    position: relative;
-    left: -4em;
-    counter-increment: source-line;
-}
-
-pre.numberSource code > span > a:first-child::before {
-    content: counter(source-line);
-    position: relative;
-    left: -1em;
-    text-align: right;
-    vertical-align: baseline;
-    border: none;
-    display: inline-block;
-    -webkit-touch-callout: none;
-    -webkit-user-select: none;
-    -khtml-user-select: none;
-    -moz-user-select: none;
-    -ms-user-select: none;
-    user-select: none;
-    padding: 0 4px;
-    width: 4em;
-    color: #aaaaaa;
-}
-
-pre.numberSource {
-    margin-left: 3em;
-    border-left: 1px solid #aaaaaa;
-    padding-left: 4px;
-}
-
-div.sourceCode {
-}
-
-@media screen {
-    pre > code.sourceCode > span > a:first-child::before {
-        text-decoration: underline;
-    }
-}
-
 code span.al {
     color: #ff0000;
     font-weight: bold;

index.html

@@ -9,8 +9,11 @@
     <title>ThoughtBank Blog</title>
 </head>
 <body>
-<main class="container" hx-get="/api/posts" hx-trigger="load">
-    Thing!
+<nav class="navbar bg-base-100">
+    <a href="/" class="btn btn-ghost text-xl">Thoughtbank Blog</a>
+</nav>
+<main class="md:container md:mx-auto" hx-get="/api/posts" hx-trigger="load">
+    <span class="htmx-indicator">Loading...</span>
 </main>
 <script type="module" src="/main.js"></script>
 </body>

main.js

@@ -1,8 +1,16 @@
-import "htmx.org";
+import htmx from "htmx.org";
 import Alpine from "alpinejs";
 import morph from "@alpinejs/morph";
 
 window.Alpine = Alpine;
 Alpine.plugin(morph);
 
 Alpine.start();
+
+htmx.on("htmx:afterSettle", () => {
+  document.querySelectorAll("time").forEach((el) => {
+    const d = new Date(el.dateTime);
+
+    el.innerText = d.toLocaleString();
+  });
+});

tailwind.config.js

@@ -7,8 +7,8 @@ export default {
         "background-size": "background-size",
       },
       backgroundSize: {
-        underline: "0% 3px",
-        "underline-hover": "100% 3px",
+        underline: "0% 2px",
+        "underline-hover": "100% 2px",
       },
     },
   },