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

Check for posts on every request to posts, posts index, or Atom Feed

Browse Source
This commit is contained in:
James Eversole 2024-03-13 18:21:49 -05:00
parent 3d5e4db7d8
commit b1bd1c3d1b
4 changed files with 79 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
sampu.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 3.0
name: sampu
version: 0.8.0
version: 0.9.0
license: ISC
author: James Eversole
maintainer: james@eversole.co

37
src/Core/HTTP.hs
View File

@ -14,11 +14,11 @@ import System.FilePath ( takeFileName )
import Web.Twain
-- Get the port to listen on from the ENV and start the webserver.
main :: [FilePath] -> IO ()
main postNames = do
main :: IO ()
main = do
port <- Conf.port
let app = preProcessors
++ (routes postNames)
++ routes
++ postProcessors
run (read port) $
foldr ($) (notFound Handle.missing) app
@ -33,25 +33,14 @@ preProcessors = [ logStdoutDev
postProcessors :: [Middleware]
postProcessors = []
{- The application's core routes expressed as a list of WAI Middlewares.
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 =
-- Core routes expressed as a list of WAI Middlewares.
routes :: [Middleware]
routes =
[ get "/" Handle.index
, get "/posts" $ Handle.postsIndex postNames
, get "/style.css" $ Handle.theme
] ++ handleDynamicPosts ++
[ get "/contact" Handle.contact
, get "/feed" $ Handle.feed postNames
, get "/atom.xml" $ Handle.feed postNames
] where
handleDynamicPosts = (buildMdRoutes postNames)
-- Takes a post's name extracted from the filepath and returns a valid route
mdFileToRoute :: FilePath -> Middleware
mdFileToRoute postName =
get (fromString $ "/posts/" ++ postName) (Handle.posts postName)
buildMdRoutes :: [FilePath] -> [Middleware]
buildMdRoutes postNames = map mdFileToRoute postNames
, 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
]

74
src/Core/Handlers.hs
View File

@ -9,13 +9,16 @@ import Fragments.Styles as S
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 qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Time.Clock (UTCTime(..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Lucid (Html)
import System.Directory (getModificationTime)
import Web.Twain
import System.Directory (doesFileExist, getModificationTime)
import System.FilePath.Find ( always, extension, fileName, find, (&&?)
, (/~?), (==?) )
import System.FilePath ( dropExtension, takeFileName )
import Web.Twain hiding (fileName)
-- A ResponoderM capable of lifting to IO monad; constructs response to clients
index :: ResponderM a
@ -29,39 +32,52 @@ index = do
-- Respond to request with fragments compositionally to create a home page
sendLucidFragment $ basePage title (baseHome homeMd) footerMd
-- Responds with processed Commonmark -> HTML for posts existing at app init
posts :: FilePath -> ResponderM a
posts postName = do
-- Responds with processed Commonmark -> HTML for posts
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 ("./data/posts/" ++ postName ++ ".md")
postMd <- liftIO $ mdFileToLucid $ postPath postName
sendLucidFragment $ basePage title (basePost postMd) footerMd
where
postExists :: T.Text -> IO Bool
postExists postName = doesFileExist $ postPath postName
-- Builds an index of all posts on filesystem as of application init
postsIndex :: [FilePath] -> ResponderM a
postsIndex postNames = do
postPath :: T.Text -> FilePath
postPath postName = "./data/posts/" ++ T.unpack postName ++ ".md"
-- 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
-- Generates the XML feed at /feed
feed :: [FilePath] -> ResponderM a
feed postNames = do
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
-- Send an XML response with an automatically populated Atom feed
send $ xml $ LTE.encodeUtf8 $ renderFeed
send $ xml $ TLE.encodeUtf8 $ renderFeed
$ autoFeed (baseFeed title time baseUrl) feedData
where
-- Base feed data structure which we populate with entries
baseFeed :: String -> String -> String -> Atom.Feed
baseFeed title time baseUrl = Atom.nullFeed
(pack $ baseUrl ++ "/feed")
(Atom.TextString $ pack title)
(pack $ time ++ " UTC")
(T.pack $ baseUrl ++ "/feed")
(Atom.TextString $ T.pack title)
(T.pack $ time ++ " UTC")
-- Create an Atom Post for each markdown post present
makePost :: String -> FilePath -> IO (Post)
@ -69,9 +85,9 @@ feed postNames = do
date <- getModificationTime $ "./data/posts/" ++ postName ++ ".md"
postContent <- mdFileToText $ "./data/posts/" ++ postName ++ ".md"
return $ Post
(pack $ (timeFormat date) ++ " UTC")
(pack $ baseUrl ++ "/posts/" ++ postName)
(pack $ show postName)
(T.pack $ (timeFormat date) ++ " UTC")
(T.pack $ baseUrl ++ "/posts/" ++ postName)
(T.pack $ show postName)
(postContent)
-- YYYY-MM-DD HH:MM | 2024-02-24 16:36
@ -88,7 +104,7 @@ contact = do
-- Respond with primary processed CSS
theme :: ResponderM a
theme = send $ css $ LTE.encodeUtf8 $ S.cssRender S.composedStyles
theme = send $ css $ TLE.encodeUtf8 $ S.cssRender S.composedStyles
-- Helper function for responding in ResponderM from Html
sendLucidFragment :: Html () -> ResponderM a
@ -97,3 +113,19 @@ sendLucidFragment x = send $ html $ lucidToTwain x
-- 404 handler
missing :: ResponderM a
missing = sendLucidFragment pageNotFound
-- List of all non-hidden .md posts that aren't part of templating
mdPostNames :: IO [FilePath]
mdPostNames = mapM (pure . dropExtension . takeFileName )
=<< find isVisible fileFilter "./data/posts"
where
isVisible = fileName /~? ".?*"
isMdFile = extension ==? ".md"
isHome = fileName /~? "home.md"
isContact = fileName /~? "contact.md"
isFooter = fileName /~? "footer.md"
fileFilter = isMdFile
&&? isVisible
&&? isHome
&&? isContact
&&? isFooter

26
src/Main.hs
View File

@ -3,31 +3,7 @@ module Main where
import qualified Core.HTTP as HTTP
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 = do
Conf.main
mdFilePaths <- getMdFilePaths "./data/posts/"
-- Pass only the post names extracted from their filepath to HTTP.main
let mdFiles = map (dropExtension . takeFileName) mdFilePaths
HTTP.main mdFiles
-- Return a list of all non-hidden .md files except for home.md and contact.md
getMdFilePaths :: FilePath -> IO [FilePath]
getMdFilePaths fp = find isVisible fileFilter fp
where
isMdFile = extension ==? ".md"
isVisible = fileName /~? ".?*"
isHome = fileName /~? "home.md"
isContact = fileName /~? "contact.md"
isFooter = fileName /~? "footer.md"
fileFilter = isMdFile
&&? isVisible
&&? isHome
&&? isContact
&&? isFooter
HTTP.main