Dynamic route and handler creation for Markdown posts

sampu.cabal

@@ -19,6 +19,8 @@ executable sampu
                       , commonmark            >= 0.2.4
                       , directory             >= 1.3.7.0
                       , dotenv                >= 0.11.0.0
+                      , filemanip             >= 0.3.6.1
+                      , filepath              >= 1.4.2.2
                       , lucid                 >= 2.11.0
                       , text                  >= 2.0
                       , twain                 >= 2.1.0.0

src/Core/HTTP.hs

@@ -1,20 +1,30 @@
 module Core.HTTP where
 
-import qualified Core.Configuration         as Conf
+import qualified Core.Configuration                   as Conf
-import qualified Core.Handlers              as Handle
+import qualified Core.Handlers                        as Handle
 
-import Network.Wai.Handler.Warp             (Port, run)
+import           Control.Monad                        ( mapM_ )
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import           Data.String                          ( fromString )
-import Network.Wai.Middleware.Static
+import           Network.Wai.Handler.Warp             ( Port, run )
+import           Network.Wai.Middleware.RequestLogger ( logStdoutDev )
+import           Network.Wai.Middleware.Static
+import           System.FilePath                      ( takeFileName )
 
-import Web.Twain
+
+import           Web.Twain
 
 -- Get the port to listen on from the ENV and start the webserver
-main :: IO ()
+main :: [FilePath] -> IO ()
-main = do
+main mdFiles = do
   port <- Conf.appPort
   run (read port :: Int) $
-    foldr ($) (notFound Handle.missing) app
+    foldr ($) (notFound Handle.missing) (app mdFiles)
+  where
+    app mdFiles = preProcessors 
+       ++ routes 
+       ++ (map mdFileToRoute mdFiles)
+       ++ postProcessors
+    
 
 -- These Middlewares are executed before any routes are reached
 preProcessors :: [Middleware]
@@ -22,11 +32,14 @@ preProcessors = [ logStdoutDev
                 , staticPolicy $ noDots >-> addBase "data/assets/public"
                 ]
 
--- The application's routes expressed as a list of WAI Middlewares
+-- These Middlewares are executed after all other routes are exhausted
+postProcessors :: [Middleware]
+postProcessors = []
+
+-- The application's core routes expressed as a list of WAI Middlewares
 routes :: [Middleware]
 routes =
   [ get "/" Handle.index ]
 
--- Combine our Preprocessor Middlewares and Routes to create an App to run
+mdFileToRoute :: FilePath -> Middleware
-app :: [Middleware]
+mdFileToRoute fp = get (fromString $ "/posts/" ++ fp) (Handle.posts fp)
-app = preProcessors ++ routes

src/Core/Handlers.hs

@@ -20,6 +20,16 @@ index = do
     $ baseNav 
    <> baseHome homeMd
 
+posts :: FilePath -> ResponderM a 
+posts fp = do
+  title <- liftIO Conf.appTitle
+  postMd <- liftIO $ mdFileToLucid 
+                   $ "./data/posts/" ++ fp ++ ".md"
+  sendLucidFragment
+    $ baseDoc title
+    $ baseNav
+    <> postMd
+  
 missing :: ResponderM a
 missing = sendLucidFragment pageNotFound
 

src/Fragments/Base.hs

@@ -10,7 +10,7 @@ baseDoc :: String -> Html () -> Html ()
 baseDoc title bodyContent = doctypehtml_ $ do
   head_ $ do
     title_ $ fromString title
-    link_ [rel_ "stylesheet", type_ "text/css", href_ "style.css"]
+    link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css"]
     script_ [src_ "/htmx.min.js"] none
   body_ bodyContent
 

src/Main.hs

@@ -1,7 +1,23 @@
 module Main where
 
-import qualified Core.HTTP          as Core
+import qualified Core.HTTP            as HTTP
-import qualified Core.Configuration as Conf
+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 = Conf.main >>= (\_ -> Core.main)
+main = do
+  Conf.main 
+  mdFilePaths <- getMdFilePaths "./data/posts/"
+  let mdFiles =  map (dropExtension . takeFileName) mdFilePaths
+  HTTP.main mdFiles
+
+getMdFilePaths :: FilePath -> IO [FilePath]
+getMdFilePaths fp = find isVisible (isMdFile &&? isVisible) fp
+  where
+    isMdFile  = extension ==? ".md"
+    isVisible = fileName  /~? ".?*"