diff --git a/sampu.cabal b/sampu.cabal index 55896fc..0f10b96 100644 --- a/sampu.cabal +++ b/sampu.cabal @@ -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 diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index 34f3451..34df9ff 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -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 + ] diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs index 9b589a5..ceed6c5 100644 --- a/src/Core/Handlers.hs +++ b/src/Core/Handlers.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index b36366c..0594bbc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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