add rss and retrying

app/Lib/Database.hs

@@ -2,14 +2,17 @@
 
 module Lib.Database where
 
-import Control.Concurrent (threadDelay)
 import Control.Monad
+import Control.Retry
 import Data.Maybe
 import Data.Text (Text)
 import Data.Text qualified as T
 import Database.MongoDB
 import Network.URI
 
+limitedBackoff :: RetryPolicyM IO
+limitedBackoff = exponentialBackoff 50000 <> limitRetries 5
+
 getDbInfo :: String -> (String, Username, Password)
 getDbInfo uri = fromJust $ do
   parsed <- parseURI uri
@@ -25,22 +28,28 @@ getDbInfo uri = fromJust $ do
 getPipe :: ReplicaSet -> Username -> Password -> IO Pipe
 getPipe rs uname passwd = do
   pipe <- primary rs
-  isAuthed <- access pipe master admin (auth uname passwd)
-  unless isAuthed (threadDelay 100000) -- wait 100ms if not authed
+  _ <-
+    retrying
+      limitedBackoff
+      (\_ b -> return $ not b)
+      $ const (access pipe master admin (auth uname passwd))
   return pipe
 
 -- pipelines
-postsPipline :: (Val v0, Val v1) => v0 -> v1 -> [Document]
-postsPipline limit offset =
+postsPipeline' :: (Val v0, Val v1) => v0 -> v1 -> [Document]
+postsPipeline' limit offset =
+  [ ["$match" =: ["published" =: True]]
+  , ["$sort" =: ["updated" =: (-1 :: Int)]]
+  , ["$limit" =: limit]
+  , ["$skip" =: offset]
+  , ["$project" =: ["published" =: (0 :: Int)]]
+  ]
+
+postsPipeline :: (Val v0, Val v1) => v0 -> v1 -> [Document]
+postsPipeline limit offset =
   [
     [ "$facet"
-        =: [ "data"
-              =: [ ["$match" =: ["published" =: True]]
-                 , ["$sort" =: ["updated" =: (-1 :: Int)]]
-                 , ["$limit" =: limit]
-                 , ["$skip" =: offset]
-                 , ["$project" =: ["published" =: (0 :: Int)]]
-                 ]
+        =: [ "data" =: postsPipeline' limit offset
            , "total"
               =: [ ["$match" =: ["published" =: True]]
                  , ["$count" =: ("total" :: Text)]

app/Lib/Middleware.hs

@@ -46,7 +46,7 @@ rewriteHtmxPosts p@(ps, qs) h = do
         htmxURI <- hoistMaybe $ parseURI . T.unpack $ decodeUtf8 htmxUrl
 
         let ps' = decodePathSegments . encodeUtf8 . T.pack $ uriPath htmxURI
-        guard ((isPrefixOf `on` filter (not . T.null)) ps ps')
+        guard ((isPrefixOf `on` dropWhileEnd T.null) ps ps')
 
         let qs' = parseQuery . encodeUtf8 . T.pack $ uriQuery htmxURI
 

app/Lib/Rss.hs

@@ -11,6 +11,9 @@ import Web.Scotty.Trans (raw, setHeader)
 
 type RSS = Markup
 
+toRss :: (ToMarkup a) => a -> RSS
+toRss = toMarkup
+
 rssXml :: RSS -> ActionM ()
 rssXml r = do
   setHeader "Content-Type" "application/rss+xml"
@@ -37,6 +40,9 @@ title = Parent "title" "<title" "</title>"
 link :: RSS -> RSS
 link = Parent "link" "<link" "</link>"
 
+guid :: RSS -> RSS
+guid = Parent "guid" "<guid" "</guid>"
+
 description :: RSS -> RSS
 description = Parent "description" "<description" "</description>"
 
@@ -51,3 +57,6 @@ atomLink = Leaf "atom:link" "<atom:link" ">" ()
 
 item :: RSS -> RSS
 item = Parent "item" "<item" "</item>"
+
+cdata :: Markup -> RSS
+cdata d = preEscapedText "<![CDATA[" >> d >> preEscapedText "]]>"

app/Lib/Types.hs

@@ -1,8 +1,18 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Lib.Types where
 
 import Control.Monad.Trans.Reader
 import Data.Pool
+import Data.Text (Text)
+import Data.Time.Calendar.Month
+import Data.Time.Clock
 import Database.MongoDB
+import Database.MongoDB qualified as M
+import GHC.Generics
 import Web.Scotty.Trans
 
 newtype Config = Config
@@ -12,3 +22,74 @@ newtype Config = Config
 type ConfigReader = ReaderT Config IO
 type ScottyM = ScottyT ConfigReader
 type ActionM = ActionT ConfigReader
+
+instance Parsable ObjectId where
+  parseParam = readEither
+
+class FromDocument a where
+  fromDocument :: Document -> a
+
+instance FromDocument Document where
+  fromDocument = id
+
+data Post = Post
+  { postId :: ObjectId
+  , postTitle :: Text
+  , postBody :: Text
+  , postCreated :: UTCTime
+  , postUpdated :: UTCTime
+  , postTags :: [Text]
+  }
+  deriving (Generic, Show, Eq)
+
+instance FromDocument Post where
+  fromDocument d = 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
+    postTags = M.at "tags" d
+
+data MonthSummary = MonthSummary
+  { summaryMonth :: Month
+  , monthCount :: Integer
+  }
+  deriving (Generic, Show, Eq)
+
+instance FromDocument MonthSummary where
+  fromDocument d = MonthSummary{..}
+   where
+    summaryMonth = YearMonth (M.at "year" d) (M.at "month" d)
+    monthCount = M.at "count" d
+
+data TagSummary = TagSummary
+  { tagName :: Text
+  , tagCount :: Integer
+  }
+  deriving (Generic, Show, Eq)
+
+instance FromDocument TagSummary where
+  fromDocument d = TagSummary{..}
+   where
+    tagName = M.at "name" d
+    tagCount = M.at "count" d
+
+data Summary = Summary
+  { monthly :: [MonthSummary]
+  , tags :: [TagSummary]
+  }
+  deriving (Generic, Show, Eq)
+
+instance FromDocument Summary where
+  fromDocument d = Summary{..}
+   where
+    monthly = map fromDocument (M.at "monthly" d)
+    tags = map fromDocument (M.at "tags" d)
+
+data Page = Page
+  { pageLimit :: Integer
+  , pageOffset :: Integer
+  }
+  deriving (Show, Eq)

app/Main.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Main where
 
@@ -14,6 +13,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Reader
+import Control.Retry
 import Data.Either
 import Data.Functor ((<&>))
 import Data.List (intersperse)
@@ -23,12 +23,10 @@ import Data.String (fromString)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Time.Calendar.Month
-import Data.Time.Clock
 import Data.Time.Format
 import Data.Time.Format.ISO8601
 import Database.MongoDB
 import Database.MongoDB qualified as M
-import GHC.Generics
 import Lib.Blaze
 import Lib.Database
 import Lib.Middleware
@@ -59,77 +57,6 @@ import Text.Pandoc (
 import Text.Pandoc.Walk
 import Web.Scotty.Trans
 
-instance Parsable ObjectId where
-  parseParam = readEither
-
-class FromDocument a where
-  fromDocument :: Document -> a
-
-instance FromDocument Document where
-  fromDocument = id
-
-data Post = Post
-  { postId :: ObjectId
-  , postTitle :: Text
-  , postBody :: Text
-  , postCreated :: UTCTime
-  , postUpdated :: UTCTime
-  , postTags :: [Text]
-  }
-  deriving (Generic, Show, Eq)
-
-instance FromDocument Post where
-  fromDocument d = 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
-    postTags = M.at "tags" d
-
-data MonthSummary = MonthSummary
-  { summaryMonth :: Month
-  , monthCount :: Integer
-  }
-  deriving (Generic, Show, Eq)
-
-instance FromDocument MonthSummary where
-  fromDocument d = MonthSummary{..}
-   where
-    summaryMonth = YearMonth (M.at "year" d) (M.at "month" d)
-    monthCount = M.at "count" d
-
-data TagSummary = TagSummary
-  { tagName :: Text
-  , tagCount :: Integer
-  }
-  deriving (Generic, Show, Eq)
-
-instance FromDocument TagSummary where
-  fromDocument d = TagSummary{..}
-   where
-    tagName = M.at "name" d
-    tagCount = M.at "count" d
-
-data Summary = Summary
-  { monthly :: [MonthSummary]
-  , tags :: [TagSummary]
-  }
-  deriving (Generic, Show, Eq)
-
-instance FromDocument Summary where
-  fromDocument d = Summary{..}
-   where
-    monthly = map fromDocument (M.at "monthly" d)
-    tags = map fromDocument (M.at "tags" d)
-
-data Page = Page
-  { pageLimit :: Integer
-  , pageOffset :: Integer
-  }
-  deriving (Show, Eq)
-
 isDebug :: IO Bool
 isDebug =
   lookupEnv "DEBUG" <&> \case
@@ -252,10 +179,11 @@ getMaxPage total page = ceiling (fromIntegral total / fromIntegral (pageLimit pa
 runDb :: (MonadIO m) => Database -> Action IO b -> ActionT (ReaderT Config m) b
 runDb dbname q = do
   pool <- getPool <$> lift ask
-  liftAndCatchIO
-    ( withResource pool $ \p ->
-        access p master dbname q
-    )
+  liftAndCatchIO $
+    recoverAll limitedBackoff $
+      const $ do
+        withResource pool $ \p ->
+          access p master dbname q
 
 main :: IO ()
 main = do
@@ -272,11 +200,10 @@ main = do
 
   rs <- openReplicaSetSRV' dbhost
 
-  pool <- newPool (defaultPoolConfig (getPipe rs uname passwd) M.close 10 3)
-
-  let f r = runReaderT r Config{getPool = pool}
+  pool <- newPool (defaultPoolConfig (getPipe rs uname passwd) M.close 10 5)
 
-  let opts =
+  let f = flip runReaderT Config{getPool = pool}
+      opts =
         defaultOptions
           { settings =
               setHost (fromString webHost) . setPort (read webPort) $
@@ -300,7 +227,7 @@ main = do
             "blog"
             ( aggregate
                 "posts"
-                ( postsPipline
+                ( postsPipeline
                     (pageLimit page)
                     (pageOffset page)
                 )
@@ -335,17 +262,14 @@ main = do
     get "/posts/:pid" $ do
       pid :: ObjectId <- captureParam "pid"
 
-      result <-
-        liftAndCatchIO
-          ( withResource pool $ \p ->
-              access p master "blog" $
-                find (select (getPost pid) "posts") >>= M.next
-          )
-
-      case result of
-        Nothing -> raiseStatus status404 "Not Found"
-        Just doc -> blazeHtml $ do
-          postHtml $ fromDocument doc
+      runDb
+        "blog"
+        ( find (select (getPost pid) "posts") >>= M.rest
+        )
+        >>= \case
+          [] -> raiseStatus status404 "Not Found"
+          doc : _ -> blazeHtml $ do
+            postHtml $ fromDocument doc
 
     get "/posts/summary" $ do
       result <-
@@ -523,10 +447,30 @@ main = do
           renderPosts docs
 
     get "/posts/feed" $ do
+      posts :: [Post] <-
+        map fromDocument
+          <$> runDb
+            "blog"
+            ( aggregate
+                "posts"
+                ( postsPipeline'
+                    (10 :: Int)
+                    (0 :: Int)
+                )
+            )
+
       rssXml $ do
         xmlHeader
         rss $ do
           title "ThoughtBank Blog"
           link "http://localhost:5173"
           description "Thoughts and concerns from my programming journey."
           language "en-us"
+          forM_ posts $ \p -> item $ do
+            let l = toRss $ "http://localhost:5173/posts/" <> show (postId p)
+
+            title . toRss $ postTitle p
+            pubDate . toRss . formatTime defaultTimeLocale "%a, %e %b %Y %R %z" $ postUpdated p
+            link l
+            guid l
+            description . cdata . mdToHtml $ postBody p