Check for posts on every request to posts, posts index, or Atom Feed

sampu.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            sampu
-version:         0.8.0
+version:         0.9.0
 license:         ISC
 author:          James Eversole
 maintainer:      james@eversole.co

src/Core/HTTP.hs

@@ -14,11 +14,11 @@ import           System.FilePath                      ( takeFileName )
 import           Web.Twain
 
 -- Get the port to listen on from the ENV and start the webserver.
-main :: [FilePath] -> IO ()
+main :: IO ()
-main postNames = do
+main = do
   port <- Conf.port
   let app = preProcessors 
-         ++ (routes postNames)
+         ++ routes
          ++ postProcessors
   run (read port) $ 
     foldr ($) (notFound Handle.missing) app
@@ -33,25 +33,14 @@ preProcessors  = [ logStdoutDev
 postProcessors :: [Middleware]
 postProcessors  = []
 
-{- The application's core routes expressed as a list of WAI Middlewares.
+-- Core routes expressed as a list of WAI Middlewares.
-   The list of post names is required so that the postsIndex handler can
+routes :: [Middleware]
-   automatically build an index of posts available to view. -}
+routes =
-routes :: [FilePath] -> [Middleware]
-routes postNames  =
   [ get "/"            Handle.index 
-  , get "/posts"     $ Handle.postsIndex postNames
+  , get "/style.css"   Handle.theme
-  , get "/style.css" $ Handle.theme
+  , get "/posts"       Handle.postsIndex
-  ]                 ++ handleDynamicPosts ++
+  , get "/posts/:name" Handle.posts
-  [ get "/contact"     Handle.contact
+  , get "/contact"     Handle.contact
-  , get "/feed"      $ Handle.feed postNames
+  , get "/atom.xml"    Handle.feed
-  , get "/atom.xml"  $ Handle.feed postNames
+  , get "/feed"        Handle.feed
-  ] where 
+  ]  
-      handleDynamicPosts = (buildMdRoutes postNames)
-
--- Takes a post's name extracted from the filepath and returns a valid route
-mdFileToRoute :: FilePath -> Middleware
-mdFileToRoute postName = 
-  get (fromString $ "/posts/" ++ postName) (Handle.posts postName)
-
-buildMdRoutes :: [FilePath] -> [Middleware]
-buildMdRoutes postNames = map mdFileToRoute postNames

src/Core/Handlers.hs

@@ -9,13 +9,16 @@ import           Fragments.Styles        as S
 
 import qualified Text.Atom.Feed          as Atom
 import           Control.Monad.IO.Class     (liftIO)
-import           Data.Text
+import qualified Data.Text               as T
-import qualified Data.Text.Lazy.Encoding as LTE
+import qualified Data.Text.Lazy.Encoding as TLE
 import           Data.Time.Clock            (UTCTime(..), getCurrentTime)
 import           Data.Time.Format           (formatTime, defaultTimeLocale)
 import           Lucid                      (Html)
-import           System.Directory        (getModificationTime)
+import           System.Directory           (doesFileExist, getModificationTime)
-import           Web.Twain
+import           System.FilePath.Find       ( always, extension, fileName, find, (&&?)
+                                            , (/~?), (==?) )
+import           System.FilePath            ( dropExtension, takeFileName )
+import           Web.Twain           hiding (fileName)
 
 -- A ResponoderM capable of lifting to IO monad; constructs response to clients
 index :: ResponderM a
@@ -29,39 +32,52 @@ index = do
   -- Respond to request with fragments compositionally to create a home page
   sendLucidFragment  $ basePage title (baseHome homeMd) footerMd
 
--- Responds with processed Commonmark -> HTML for posts existing at app init
+-- Responds with processed Commonmark -> HTML for posts
-posts :: FilePath -> ResponderM a 
+posts :: ResponderM a 
-posts postName = do
+posts = do
+  postName  <- param "name"
+  postValid <- liftIO $ postExists postName
+  case postValid of
+    False  -> missing
+    True   -> do
       title    <- liftIO Conf.title
       footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md"
-  postMd   <- liftIO $ mdFileToLucid ("./data/posts/" ++ postName ++ ".md")
+      postMd   <- liftIO $ mdFileToLucid $ postPath postName
       sendLucidFragment  $ basePage title (basePost postMd) footerMd
+    where
+      postExists :: T.Text -> IO Bool
+      postExists postName = doesFileExist $ postPath postName
 
--- Builds an index of all posts on filesystem as of application init
+      postPath :: T.Text -> FilePath
-postsIndex :: [FilePath] -> ResponderM a
+      postPath postName = "./data/posts/" ++ T.unpack postName ++ ".md"
-postsIndex postNames = do
+
+-- Builds an index of all posts
+postsIndex :: ResponderM a
+postsIndex = do
+  postNames <- liftIO   mdPostNames
   title     <- liftIO   Conf.title
   footerMd  <- liftIO $ mdFileToLucid "./data/posts/footer.md"
   sendLucidFragment   $ basePage title (postIndex postNames) footerMd
 
 -- Generates the XML feed at /feed
-feed :: [FilePath] -> ResponderM a
+feed :: ResponderM a
-feed postNames = do
+feed = do
+  postNames <- liftIO   mdPostNames
   title     <- liftIO   Conf.title
   baseUrl   <- liftIO   Conf.baseUrl
   time      <- liftIO $ fmap (\x -> timeFormat x) getCurrentTime
   -- Create Atom [Post] to populate the feed
   feedData  <- liftIO $ mapM (makePost baseUrl) postNames
   -- Send an XML response with an automatically populated Atom feed
-  send $ xml $ LTE.encodeUtf8 $ renderFeed 
+  send $ xml $ TLE.encodeUtf8 $ renderFeed 
        $ autoFeed (baseFeed title time baseUrl) feedData
     where
       -- Base feed data structure which we populate with entries
       baseFeed :: String -> String -> String -> Atom.Feed
       baseFeed title time baseUrl = Atom.nullFeed
-        (pack $ baseUrl ++ "/feed")
+        (T.pack $ baseUrl ++ "/feed")
-        (Atom.TextString $ pack title)
+        (Atom.TextString $ T.pack title)
-        (pack $ time ++ " UTC")
+        (T.pack $ time ++ " UTC")
 
       -- Create an Atom Post for each markdown post present
       makePost :: String -> FilePath -> IO (Post)
@@ -69,9 +85,9 @@ feed postNames = do
         date <- getModificationTime $ "./data/posts/" ++ postName ++ ".md"
         postContent <- mdFileToText $ "./data/posts/" ++ postName ++ ".md"
         return  $ Post 
-          (pack $ (timeFormat date) ++ " UTC")
+          (T.pack $ (timeFormat date) ++ " UTC")
-          (pack $ baseUrl ++ "/posts/" ++ postName) 
+          (T.pack $ baseUrl ++ "/posts/" ++ postName) 
-          (pack $ show postName)
+          (T.pack $ show postName)
           (postContent)
 
       -- YYYY-MM-DD HH:MM | 2024-02-24 16:36
@@ -88,7 +104,7 @@ contact = do
 
 -- Respond with primary processed CSS
 theme :: ResponderM a
-theme = send $ css $ LTE.encodeUtf8 $ S.cssRender S.composedStyles
+theme = send $ css $ TLE.encodeUtf8 $ S.cssRender S.composedStyles
 
 -- Helper function for responding in ResponderM from Html 
 sendLucidFragment :: Html () -> ResponderM a
@@ -97,3 +113,19 @@ sendLucidFragment x = send $ html $ lucidToTwain x
 -- 404 handler
 missing :: ResponderM a
 missing = sendLucidFragment pageNotFound
+
+-- List of all non-hidden .md posts that aren't part of templating
+mdPostNames :: IO [FilePath]
+mdPostNames = mapM (pure . dropExtension . takeFileName )
+                =<< find isVisible fileFilter "./data/posts"
+                       where
+                         isVisible  = fileName  /~? ".?*"
+                         isMdFile   = extension ==? ".md"
+                         isHome     = fileName  /~? "home.md"
+                         isContact  = fileName  /~? "contact.md"
+                         isFooter   = fileName  /~? "footer.md"
+                         fileFilter = isMdFile
+                                  &&? isVisible
+                                  &&? isHome
+                                  &&? isContact
+                                  &&? isFooter

src/Main.hs

@@ -3,31 +3,7 @@ module Main where
 import qualified Core.HTTP            as HTTP
 import qualified Core.Configuration   as Conf
 
-import           Control.Monad        ( mapM_ )
-import           System.FilePath.Find ( always, extension, fileName, find, (&&?)
-                                      , (/~?), (==?) )
-import           System.FilePath      ( dropExtension, takeFileName )
-
-
 main :: IO ()
 main = do
   Conf.main 
-  mdFilePaths <- getMdFilePaths "./data/posts/"
+  HTTP.main
-  -- Pass only the post names extracted from their filepath to HTTP.main
-  let mdFiles =  map (dropExtension . takeFileName) mdFilePaths
-  HTTP.main mdFiles
-
--- Return a list of all non-hidden .md files except for home.md and contact.md
-getMdFilePaths :: FilePath -> IO [FilePath]
-getMdFilePaths fp = find isVisible fileFilter fp
-  where
-    isMdFile   = extension ==? ".md"
-    isVisible  = fileName  /~? ".?*"
-    isHome     = fileName  /~? "home.md"
-    isContact  = fileName  /~? "contact.md"
-    isFooter   = fileName  /~? "footer.md"
-    fileFilter = isMdFile 
-             &&? isVisible 
-             &&? isHome 
-             &&? isContact 
-             &&? isFooter