diff --git a/sampu.cabal b/sampu.cabal index d007206..61221e0 100644 --- a/sampu.cabal +++ b/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 diff --git a/src/Core/Feed.hs b/src/Core/Feed.hs new file mode 100644 index 0000000..afac4f0 --- /dev/null +++ b/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) diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index ca75bf4..84d301a 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -18,9 +18,8 @@ main :: [FilePath] -> IO () main postNames = do port <- Conf.appPort let app = preProcessors - ++ (routes postNames) - ++ (buildMdRoutes postNames) - ++ postProcessors + ++ (routes postNames) + ++ postProcessors run (read port) $ foldr ($) (notFound Handle.missing) app @@ -38,11 +37,12 @@ postProcessors = [] The list of post names is required so that the postsIndex handler can automatically build an index of posts available to view. -} routes :: [FilePath] -> [Middleware] -routes postNames = - [ get "/" Handle.index - , get "/posts" $ Handle.postsIndex postNames - , get "/contact" Handle.contact - , get "/feed" Handle.feed +routes postNames = + [ get "/" Handle.index + , get "/posts" $ Handle.postsIndex postNames + ] ++ (buildMdRoutes postNames) ++ + [ get "/contact" Handle.contact + , get "/feed" $ Handle.feed postNames ] -- Takes a post's name extracted from the filepath and returns a valid route diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs index 708ba5e..a712309 100644 --- a/src/Core/Handlers.hs +++ b/src/Core/Handlers.hs @@ -1,45 +1,87 @@ module Core.Handlers where -import qualified Core.Configuration as Conf +import qualified Core.Configuration as Conf import Core.Rendering +import Core.Feed (Post(..), autoFeed, renderFeed) import Fragments.Base import Fragments.NotFound -import Control.Monad.IO.Class (liftIO) -import Lucid (Html) +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 -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 - +-- 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.appTitle - homeMd <- liftIO $ mdFileToLucid "./data/posts/home.md" + -- 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 -missing = sendLucidFragment pageNotFound - +-- Responds with processed Commonmark -> HTML for posts existing at app init posts :: FilePath -> ResponderM a posts postName = do - title <- liftIO Conf.appTitle - postMd <- liftIO $ mdFileToLucid ("./data/posts/" ++ postName ++ ".md") + 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 diff --git a/src/Fragments/Base.hs b/src/Fragments/Base.hs index bf54273..0288940 100644 --- a/src/Fragments/Base.hs +++ b/src/Fragments/Base.hs @@ -1,7 +1,5 @@ module Fragments.Base where -import Core.Rendering - import Data.Text import Data.String (fromString) import Lucid