diff --git a/README.md b/README.md index cf666f8..2afed1c 100644 --- a/README.md +++ b/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 diff --git a/sampu.cabal b/sampu.cabal index 08b78aa..e62c06b 100644 --- a/sampu.cabal +++ b/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 diff --git a/src/Core/Feed.hs b/src/Core/Feed.hs index 5a0c085..4d5e865 100644 --- a/src/Core/Feed.hs +++ b/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) - { Atom.entryLinks = [Atom.nullLink url] +toEntry (Post date url title content) = (Atom.nullEntry url (Atom.TextString title) date) + { Atom.entryLinks = [Atom.nullLink url] , Atom.entryContent = Just (Atom.HTMLContent content) } diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index 34df9ff..07c36d1 100644 --- a/src/Core/HTTP.hs +++ b/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 - ] + ] diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs index ceed6c5..b0439dd 100644 --- a/src/Core/Handlers.hs +++ b/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 - -- Query the system environment for the BLOGTITLE environment variable - title <- liftIO Conf.title - -- Read a Commonmark Markdown file and process it to HTML - homeMd <- liftIO $ mdFileToLucid "./data/posts/home.md" - -- Get the Footer content from Markdown - footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md" +index = do + (title, homeMd, footerMd) <- liftIO $ (,,) + <$> Conf.title + <*> mdFileToLucid "./data/posts/home.md" + <*> 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 - footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md" - postMd <- liftIO $ mdFileToLucid $ postPath postName - sendLucidFragment $ basePage title (basePost postMd) footerMd + (title, footerMd, postMd) <- liftIO $ (,,) + <$> Conf.title + <*> mdFileToLucid "./data/posts/footer.md" + <*> (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 - title <- liftIO Conf.title - footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md" - sendLucidFragment $ basePage title (postIndex postNames) footerMd + (postNames, title, footerMd) <- liftIO $ (,,) + <$> mdPostNames + <*> Conf.title + <*> 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 - 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 + (postNames, title, baseUrl, time) <- liftIO $ (,,,) + <$> mdPostNames + <*> Conf.title + <*> Conf.baseUrl + <*> fmap (\x -> timeFormat x) getCurrentTime + 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 - contactMd <- liftIO $ mdFileToLucid "./data/posts/contact.md" - footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md" + (title, contactMd, footerMd) <- liftIO $ (,,) + <$> Conf.title + <*> 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 diff --git a/src/Core/Rendering.hs b/src/Core/Rendering.hs index cc4ff54..8eb5bbc 100644 --- a/src/Core/Rendering.hs +++ b/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 diff --git a/src/Fragments/Base.hs b/src/Fragments/Base.hs index bb08c9b..5435b81 100644 --- a/src/Fragments/Base.hs +++ b/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 + diff --git a/src/Fragments/NotFound.hs b/src/Fragments/NotFound.hs deleted file mode 100644 index bbf7e46..0000000 --- a/src/Fragments/NotFound.hs +++ /dev/null @@ -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") diff --git a/src/Fragments/Styles.hs b/src/Fragments/Styles.hs index 7af4a65..6b4932a 100644 --- a/src/Fragments/Styles.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 0594bbc..7c5ea8c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,5 +5,5 @@ import qualified Core.Configuration as Conf main :: IO () main = do - Conf.main + Conf.main HTTP.main