Functioning XML feed auto-generation based on files present at app initialization

sampu.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            sampu
-version:         0.2.0
+version:         0.3.0
 license:         ISC
 author:          James Eversole
 maintainer:      james@eversole.co
@@ -19,16 +19,20 @@ executable sampu
                       , commonmark            >= 0.2.4
                       , directory             >= 1.3.7.0
                       , dotenv                >= 0.11.0.0
+                      , feed                  >= 1.3.2.0
                       , filemanip             >= 0.3.6.1
                       , filepath              >= 1.4.2.2
                       , lucid                 >= 2.11.0
                       , text                  >= 2.0
+                      , time                  >= 1.12.0
                       , twain                 >= 2.1.0.0
                       , wai-extra             >= 3.0 && < 3.2
                       , wai-middleware-static >= 0.9.0
                       , warp                  == 3.3.25
+                      , xml-conduit           >= 1.9.1.0
     hs-source-dirs:     src
     other-modules:      Core.Configuration
+                        Core.Feed
                         Core.Handlers
                         Core.HTTP
                         Core.Rendering

src/Core/Feed.hs

@@ -0,0 +1,27 @@
+module Core.Feed where
+
+import           Data.Maybe
+import           Data.Text
+
+import qualified Data.Text.Lazy   as LT
+import qualified Text.Atom.Feed   as Atom
+import qualified Text.Feed.Export as Export (textFeedWith)
+import           Text.Feed.Types
+import           Text.XML (def, rsPretty)
+
+data Post = Post { _date     :: Text
+                 , _url      :: Text
+                 , _content  :: Text
+                 }
+
+-- Automatically populate Atom Feed with entries
+autoFeed :: Atom.Feed -> [Post] -> Atom.Feed
+autoFeed baseFeed feedData = baseFeed { Atom.feedEntries = fmap toEntry feedData }
+
+-- Render the Atom Feed to Lazy Text
+renderFeed :: Atom.Feed -> LT.Text
+renderFeed = fromJust . Export.textFeedWith def{rsPretty = True} . AtomFeed
+
+-- Convert a Post to an Atom Entry
+toEntry :: Post -> Atom.Entry
+toEntry (Post date url content) = (Atom.nullEntry url (Atom.TextString content) date)

src/Core/HTTP.hs

@@ -19,7 +19,6 @@ main postNames = do
   port <- Conf.appPort
   let app = preProcessors 
          ++ (routes postNames)
-            ++ (buildMdRoutes postNames)
          ++ postProcessors
   run (read port) $ 
     foldr ($) (notFound Handle.missing) app
@@ -41,8 +40,9 @@ routes :: [FilePath] -> [Middleware]
 routes postNames  =
   [ get "/"         Handle.index 
   , get "/posts"  $ Handle.postsIndex postNames
-  , get "/contact" Handle.contact
+  ] ++ (buildMdRoutes postNames) ++ 
-  , get "/feed"    Handle.feed
+  [ get "/contact"  Handle.contact
+  , get "/feed"   $ Handle.feed postNames
   ]
 
 -- Takes a post's name extracted from the filepath and returns a valid route

src/Core/Handlers.hs

@@ -2,44 +2,86 @@ module Core.Handlers where
 
 import qualified Core.Configuration      as Conf
 import           Core.Rendering 
+import           Core.Feed               (Post(..), autoFeed, renderFeed)
 import           Fragments.Base
 import           Fragments.NotFound
 
+import qualified Text.Atom.Feed          as Atom
 import           Control.Monad.IO.Class  (liftIO)
+import           Data.Text
+import qualified Data.Text.Lazy.Encoding as LTE
+import           Data.Time.Clock         (UTCTime(..), getCurrentTime)
+import           Data.Time.Format        (formatTime, defaultTimeLocale)
 import           Lucid                   (Html)
+import           System.Directory        (getModificationTime)
 import           Web.Twain
 
-contact :: ResponderM a
+-- A ResponoderM capable of lifting to IO monad; constructs response to clients
-contact = do
-  title <- liftIO Conf.appTitle
-  contactMd <- liftIO $ mdFileToLucid "./data/posts/contact.md"
-  sendLucidFragment $ basePage title (baseContact contactMd)
-
-feed :: ResponderM a
-feed = do
-  title <- liftIO Conf.appTitle
-  sendLucidFragment $ basePage title baseFeed
-  
 index :: ResponderM a
 index = do 
+  -- Query the system environment for the BLOGTITLE environment variable
   title  <- liftIO Conf.appTitle
+  -- Read a Commonmark Markdown file and process it to HTML
   homeMd <- liftIO  $ mdFileToLucid "./data/posts/home.md"
+  -- Respond to request with fragments compositionally to create a home page
   sendLucidFragment $ basePage title (baseHome homeMd)
 
-missing :: ResponderM a
+-- Responds with processed Commonmark -> HTML for posts existing at app init
-missing = sendLucidFragment pageNotFound
-
 posts :: FilePath -> ResponderM a 
 posts postName = do
   title  <- liftIO Conf.appTitle
   postMd <- liftIO  $ mdFileToLucid ("./data/posts/" ++ postName ++ ".md")
   sendLucidFragment $ basePage title (basePost postMd)
 
+-- Builds an index of all posts on filesystem as of application init
 postsIndex :: [FilePath] -> ResponderM a
 postsIndex postNames = do
   title <- liftIO Conf.appTitle
   sendLucidFragment $ basePage title (postIndex postNames)
 
+-- Generates the XML feed at /feed
+feed :: [FilePath] -> ResponderM a
+feed postNames = do
+  title     <- liftIO   Conf.appTitle
+  time      <- liftIO $ fmap (\x -> timeFormat x) getCurrentTime
+  -- Create Atom [Post] to populate the feed
+  feedData  <- liftIO $ mapM makePost postNames
+  -- Send an XML response with an automatically populated Atom feed
+  send $ xml $ LTE.encodeUtf8 $ renderFeed 
+       $ autoFeed (baseFeed title time) feedData
+    where
+      -- Base feed data structure which we populate with entries
+      baseFeed :: String -> String -> Atom.Feed
+      baseFeed title time = Atom.nullFeed
+        "https://eversole.co/feed"
+        (Atom.TextString $ pack title)
+        (pack $ time ++ " UTC")
+
+      -- Create an Atom Post for each markdown post present
+      makePost :: FilePath -> IO (Post)
+      makePost x = do 
+        date   <- getModificationTime $ "./data/posts/" ++ x ++ ".md"
+        return  $ Post 
+          (pack $ (timeFormat date) ++ " UTC")
+          (pack $ "https://eversole.co/posts/" ++ x) 
+          (pack $ show x)
+
+      -- YYYY-MM-DD HH:MM | 2024-02-24 16:36
+      timeFormat :: UTCTime -> String
+      timeFormat x = formatTime defaultTimeLocale "%Y-%m-%d %H:%M" x
+        
+-- Refer to index comments
+contact :: ResponderM a
+contact = do
+  title     <- liftIO Conf.appTitle
+  contactMd <- liftIO $ mdFileToLucid "./data/posts/contact.md"
+  sendLucidFragment   $ basePage title (baseContact contactMd)
+
+
 -- Helper function for responding in ResponderM from Html 
 sendLucidFragment :: Html () -> ResponderM a
 sendLucidFragment x = send $ html $ lucidToTwain x
+
+-- 404 handler
+missing :: ResponderM a
+missing = sendLucidFragment pageNotFound

src/Fragments/Base.hs

@@ -1,7 +1,5 @@
 module Fragments.Base where
 
-import Core.Rendering 
-
 import Data.Text
 import Data.String    (fromString)
 import Lucid