James/sampu
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Functioning XML feed auto-generation based on files present at app initialization

Browse Source
This commit is contained in:
James Eversole 2024-02-24 16:55:03 -06:00
parent 103a729508
commit c6bfc90897
5 changed files with 102 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
sampu.cabal
View File

@ -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

27
src/Core/Feed.hs Normal file
View File

@ -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)

16
src/Core/HTTP.hs
View File

@ -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

82
src/Core/Handlers.hs
View File

@ -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

2
src/Fragments/Base.hs
View File

@ -1,7 +1,5 @@
module Fragments.Base where
import Core.Rendering
import Data.Text
import Data.String (fromString)
import Lucid