Clarify IO usage via Applicative interface in Handlers, whitespace cleanup, remove dedicated source file for 404 view

README.md

@@ -1,6 +1,6 @@
 # the sampu Haskell blog engine
 
-https://eversole.co (not live yet!)
+https://eversole.co
 
 a _work-in-progress_ blog engine using simple flat-file Markdown content storage
 

sampu.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            sampu
-version:         0.9.1
+version:         0.9.2
 license:         ISC
 author:          James Eversole
 maintainer:      james@eversole.co
@@ -38,6 +38,5 @@ executable sampu
                         Core.HTTP
                         Core.Rendering
                         Fragments.Base
-                        Fragments.NotFound
                         Fragments.Styles
     default-language:   GHC2021

src/Core/Feed.hs

@@ -25,7 +25,7 @@ renderFeed = fromJust . Export.textFeedWith def{rsPretty = True} . AtomFeed
 
 -- Convert a Post to an Atom Entry
 toEntry :: Post -> Atom.Entry
-toEntry (Post date url title content) = (Atom.nullEntry url (Atom.TextString title) date) 
+toEntry (Post date url title content) = (Atom.nullEntry url (Atom.TextString title) date)
-  { Atom.entryLinks = [Atom.nullLink url] 
+  { Atom.entryLinks = [Atom.nullLink url]
   , Atom.entryContent = Just (Atom.HTMLContent content)
   }

src/Core/HTTP.hs

@@ -17,10 +17,10 @@ import           Web.Twain
 main :: IO ()
 main = do
   port <- Conf.port
-  let app = preProcessors 
+  let app = preProcessors
          ++ routes
          ++ postProcessors
-  run (read port) $ 
+  run (read port) $
     foldr ($) (notFound Handle.missing) app
 
 -- These Middlewares are executed before any routes are reached.
@@ -36,11 +36,11 @@ postProcessors  = []
 -- Core routes expressed as a list of WAI Middlewares.
 routes :: [Middleware]
 routes =
-  [ get "/"            Handle.index 
+  [ get "/"            Handle.index
   , get "/style.css"   Handle.theme
   , get "/posts"       Handle.postsIndex
   , get "/posts/:name" Handle.posts
   , get "/contact"     Handle.contact
   , get "/atom.xml"    Handle.feed
   , get "/feed"        Handle.feed
-  ]  
+  ]

src/Core/Handlers.hs

@@ -2,9 +2,8 @@ module Core.Handlers where
 
 import qualified Core.Configuration      as Conf
 import           Core.Feed                  (Post(..), autoFeed, renderFeed)
-import           Core.Rendering 
+import           Core.Rendering
 import           Fragments.Base
-import           Fragments.NotFound
 import           Fragments.Styles        as S
 
 import qualified Text.Atom.Feed          as Atom
@@ -22,28 +21,27 @@ import           Web.Twain           hiding (fileName)
 
 -- A ResponoderM capable of lifting to IO monad; constructs response to clients
 index :: ResponderM a
-index = do 
+index = do
-  -- Query the system environment for the BLOGTITLE environment variable
+  (title, homeMd, footerMd) <- liftIO $ (,,)
-  title    <- liftIO   Conf.title
+    <$> Conf.title
-  -- Read a Commonmark Markdown file and process it to HTML
+    <*> mdFileToLucid "./data/posts/home.md"
-  homeMd   <- liftIO $ mdFileToLucid "./data/posts/home.md"
+    <*> mdFileToLucid "./data/posts/footer.md"
-  -- Get the Footer content from Markdown
-  footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md"
   -- Respond to request with fragments compositionally to create a home page
-  sendLucidFragment  $ basePage title (baseHome homeMd) footerMd
+  sendLucidFragment $ basePage title (baseHome homeMd) footerMd
 
 -- Responds with processed Commonmark -> HTML for posts
-posts :: ResponderM a 
+posts :: ResponderM a
 posts = do
   postName  <- param "name"
   postValid <- liftIO $ postExists postName
   case postValid of
     False  -> missing
     True   -> do
-      title    <- liftIO Conf.title
+      (title, footerMd, postMd) <- liftIO $ (,,)
-      footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md"
+        <$> Conf.title
-      postMd   <- liftIO $ mdFileToLucid $ postPath postName
+        <*> mdFileToLucid "./data/posts/footer.md"
-      sendLucidFragment  $ basePage title (basePost postMd) footerMd
+        <*> (mdFileToLucid $ postPath postName)
+      sendLucidFragment $ basePage title (basePost postMd) footerMd
     where
       postExists :: T.Text -> IO Bool
       postExists postName = doesFileExist $ postPath postName
@@ -54,22 +52,23 @@ posts = do
 -- Builds an index of all posts
 postsIndex :: ResponderM a
 postsIndex = do
-  postNames <- liftIO   mdPostNames
+  (postNames, title, footerMd) <- liftIO $ (,,)
-  title     <- liftIO   Conf.title
+    <$> mdPostNames
-  footerMd  <- liftIO $ mdFileToLucid "./data/posts/footer.md"
+    <*> Conf.title
-  sendLucidFragment   $ basePage title (postIndex postNames) footerMd
+    <*> mdFileToLucid "./data/posts/footer.md"
+  sendLucidFragment $ basePage title (postIndex postNames) footerMd
 
 -- Generates the XML feed at /feed
 feed :: ResponderM a
 feed = do
-  postNames <- liftIO   mdPostNames
+  (postNames, title, baseUrl, time) <- liftIO $ (,,,)
-  title     <- liftIO   Conf.title
+    <$> mdPostNames
-  baseUrl   <- liftIO   Conf.baseUrl
+    <*> Conf.title
-  time      <- liftIO $ fmap (\x -> timeFormat x) getCurrentTime
+    <*> Conf.baseUrl
-  -- Create Atom [Post] to populate the feed
+    <*> fmap (\x -> timeFormat x) getCurrentTime
-  feedData  <- liftIO $ mapM (makePost baseUrl) postNames
+  feedData <- liftIO $ mapM (makePost baseUrl) postNames
   -- Send an XML response with an automatically populated Atom feed
-  send $ xml $ TLE.encodeUtf8 $ renderFeed 
+  send $ xml $ TLE.encodeUtf8 $ renderFeed
        $ autoFeed (baseFeed title time baseUrl) feedData
     where
       -- Base feed data structure which we populate with entries
@@ -81,12 +80,12 @@ feed = do
 
       -- Create an Atom Post for each markdown post present
       makePost :: String -> FilePath -> IO (Post)
-      makePost baseUrl postName = do 
+      makePost baseUrl postName = do
         date <- getModificationTime $ "./data/posts/" ++ postName ++ ".md"
         postContent <- mdFileToText $ "./data/posts/" ++ postName ++ ".md"
-        return  $ Post 
+        return  $ Post
           (T.pack $ (timeFormat date) ++ " UTC")
-          (T.pack $ baseUrl ++ "/posts/" ++ postName) 
+          (T.pack $ baseUrl ++ "/posts/" ++ postName)
           (T.pack $ show postName)
           (postContent)
 
@@ -97,16 +96,17 @@ feed = do
 -- Refer to index comments
 contact :: ResponderM a
 contact = do
-  title     <- liftIO Conf.title
+  (title, contactMd, footerMd) <- liftIO $ (,,)
-  contactMd <- liftIO $ mdFileToLucid "./data/posts/contact.md"
+    <$> Conf.title
-  footerMd  <- liftIO $ mdFileToLucid "./data/posts/footer.md"
+    <*> mdFileToLucid "./data/posts/contact.md"
+    <*> mdFileToLucid "./data/posts/footer.md"
   sendLucidFragment   $ basePage title (baseContact contactMd) footerMd
 
 -- Respond with primary processed CSS
 theme :: ResponderM a
 theme = send $ css $ TLE.encodeUtf8 $ S.cssRender S.composedStyles
 
--- Helper function for responding in ResponderM from Html 
+-- Helper function for responding in ResponderM from Html
 sendLucidFragment :: Html () -> ResponderM a
 sendLucidFragment x = send $ html $ lucidToTwain x
 

src/Core/Rendering.hs

@@ -21,6 +21,6 @@ mdFileToLucid :: FilePath -> IO (LU.Html ())
 mdFileToLucid path = fmap (mdToLucid . decodeUtf8) (B.readFile path)
 
 mdFileToText :: FilePath -> IO (Text)
-mdFileToText path = do 
+mdFileToText path = do
   htmlContent <- mdFileToLucid path
   return $ toStrict $ LU.renderText htmlContent

src/Fragments/Base.hs

@@ -44,5 +44,10 @@ postIndex postNames = div_ [class_ "postList"] $ do
       (\x -> li_ $ a_ [href_ (pack $ "/posts/" ++ x)] (fromString x))
       postNames
 
+pageNotFound :: Html ()
+pageNotFound = baseDoc "404" baseNav <>
+  (div_ [class_ "notFound"] $ h1_ "404 NOT FOUND")
+
 none :: Text
 none = mempty
+

src/Fragments/NotFound.hs

@@ -1,9 +0,0 @@
-module Fragments.NotFound where
-
-import Fragments.Base 
-
-import Lucid
-
-pageNotFound :: Html ()
-pageNotFound = baseDoc "404" baseNav <>
-  (div_ [class_ "notFound"] $ h1_ "404 NOT FOUND")

src/Fragments/Styles.hs

@@ -61,7 +61,7 @@ footer_ = do
     margin            auto (em 0) (em 0) (em 0)
     width           $ pct 100
     backgroundColor   terColor
-    textAlign         center  
+    textAlign         center
     padding           (em 1) (em 0) (em 1) (em 0)
     boxSizing         borderBox
     p ? do
@@ -92,7 +92,7 @@ notFound_ :: Css
 notFound_ = do
   ".notFound" ? do
     margin    (em 0) auto (em 0) auto
-    textAlign center 
+    textAlign center
     h1 ? do
       fontSize   $ pct 500
       fontWeight $ weight 200

src/Main.hs

@@ -5,5 +5,5 @@ import qualified Core.Configuration   as Conf
 
 main :: IO ()
 main = do
-  Conf.main 
+  Conf.main
   HTTP.main