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
]

96
src/Core/Handlers.hs
View File

@ -1,21 +1,24 @@
module Core.Handlers where
import qualified Core.Configuration as Conf
import Core.Feed (Post(..), autoFeed, renderFeed)
import Core.Feed (Post(..), autoFeed, renderFeed)
import Core.Rendering
import Fragments.Base
import Fragments.NotFound
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 Data.Time.Clock (UTCTime(..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Lucid (Html)
import System.Directory (getModificationTime)
import Web.Twain
import Control.Monad.IO.Class (liftIO)
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 (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
title <- liftIO Conf.title
footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md"
postMd <- liftIO $ mdFileToLucid ("./data/posts/" ++ postName ++ ".md")
sendLucidFragment $ basePage title (basePost postMd) footerMd
-- 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 $ 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
title <- liftIO Conf.title
footerMd <- liftIO $ mdFileToLucid "./data/posts/footer.md"
sendLucidFragment $ basePage title (postIndex postNames) footerMd
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