From 81e01e242c28ef53ec2f0dfafc921485dd6fd7d7 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 22 Feb 2024 19:58:34 -0600 Subject: [PATCH] Working Markdown processing and rendering --- .gitignore | 1 + README.md | 17 +++++++++-------- sampu.cabal | 1 + src/Core/Configuration.hs | 38 +++++++++++++++++++++++++++++++++----- src/Core/HTTP.hs | 4 +--- src/Core/Handlers.hs | 30 +++++++++++++++--------------- src/Core/Rendering.hs | 21 +++++++++++++++++---- src/Fragments/Base.hs | 16 +++++++--------- 8 files changed, 84 insertions(+), 44 deletions(-) diff --git a/.gitignore b/.gitignore index e09ae66..828af47 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,7 @@ Dockerfile WD bin/ data/posts +data/base dist* docker-stack.yml result diff --git a/README.md b/README.md index f68bb7c..1c88758 100644 --- a/README.md +++ b/README.md @@ -1,31 +1,32 @@ # the sampu Haskell blog engine -https://blog.eversole.co (not live yet!) +https://eversole.co (not live yet!) a _work-in-progress_ blog engine using simple flat-file Markdown content storage sampu is a word in [Lojban](https://mw.lojban.org) with the English definition: + "x1 is __simple__/__unmixed__/__uncomplicated__ in property x2" Therefore, `la sampu cu sampu lo ka samtci`! ## Stack -- ["Haskell"](https://www.haskell.org) -- ["Twain"](https://github.com/alexmingoia/twain) -- ["Lucid2"](https://chrisdone.com/posts/lucid2) -- ["HTMX"](https://htmx.org/) +- [Haskell](https://www.haskell.org) +- [Twain](https://github.com/alexmingoia/twain) +- [Lucid2](https://chrisdone.com/posts/lucid2) +- [HTMX](https://htmx.org/) ## Goal Provide a simple blog engine that is easily customizable via HTML fragments -and easy HTMX integration for dynamic content. +and straightforward HTMX integration for dynamic server-driven content. ## Deployment -We're not there yet, but soon! This project is built and packaged with Nix, +We're not there yet! This project is built and packaged with Nix, so I will provide directions on deploying with Nix as well as via OCI -containers once there's something viable to run here. +containers once there's something viable to run. ## Development and Support diff --git a/sampu.cabal b/sampu.cabal index 8e75765..1cca3c4 100644 --- a/sampu.cabal +++ b/sampu.cabal @@ -17,6 +17,7 @@ executable sampu build-depends: base , bytestring >= 0.11.5.0 , commonmark >= 0.2.4 + , directory >= 1.3.7.0 , dotenv >= 0.11.0.0 , lucid >= 2.11.0 , text >= 2.0 diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs index 181fbb9..45b31d6 100644 --- a/src/Core/Configuration.hs +++ b/src/Core/Configuration.hs @@ -1,17 +1,45 @@ module Core.Configuration where import Configuration.Dotenv -import System.Environment (getEnv, lookupEnv) +import System.Directory (doesFileExist) +import System.Environment (getEnv, lookupEnv) + +-- Load environment variables from dotenv file if required main :: IO () main = do - envFile <- lookupEnv "NOENVFILE" - case envFile of - Nothing -> loadFile defaultConfig - _ -> putStrLn "Not using dotenv" + reqEnvLookup <- getRequiredEnv + if (Nothing `elem` reqEnvLookup) + then checkEnvFile requiredEnvVars + else pure () + where + getRequiredEnv :: IO [Maybe String] + getRequiredEnv = mapM (\s -> lookupEnv s) requiredEnvVars + + checkEnvFile :: [String] -> IO () + checkEnvFile requiredEnv = do + dotEnvExists <- doesFileExist "./.env" + if dotEnvExists + then do + loadFile defaultConfig + fromEnvFile <- getRequiredEnv + if (Nothing `elem` fromEnvFile) + then error $ missingEnvMsg requiredEnv + else pure () + else error $ "Cannot find .env file in application directory.\n" + ++ missingEnvMsg requiredEnv + + missingEnvMsg :: [String] -> String + missingEnvMsg required = + "Missing required environment variable(s).\n" + ++ "All required environment variables:\n" + ++ unlines required appPort :: IO String appPort = getEnv "APPLICATIONPORT" appTitle :: IO String appTitle = getEnv "BLOGTITLE" + +requiredEnvVars :: [String] +requiredEnvVars = [ "APPLICATIONPORT", "BLOGTITLE" ] diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index 30be52c..08cb4c4 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -25,9 +25,7 @@ preProcessors = [ logStdoutDev -- The application's routes expressed as a list of WAI Middlewares routes :: [Middleware] routes = - [ get "/" Handle.index - , get "/echo/:testParam" Handle.testRoute - ] + [ get "/" Handle.index ] -- Combine our Preprocessor Middlewares and Routes to create an App to run app :: [Middleware] diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs index a026a7d..a3dfca8 100644 --- a/src/Core/Handlers.hs +++ b/src/Core/Handlers.hs @@ -1,27 +1,27 @@ module Core.Handlers where import qualified Core.Configuration as Conf -import qualified Core.Rendering as R -import Fragments.Base -import Fragments.NotFound +import Core.Rendering +import Fragments.Base +import Fragments.NotFound -import Control.Monad.IO.Class (liftIO) -import Lucid (Html) -import Web.Twain +import Control.Monad.IO.Class (liftIO) +import Lucid (Html) +import Web.Twain index :: ResponderM a -index = liftIO Conf.appTitle >>= (\title -> +index = do + -- Probably going to want to add ReaderT to the stack for this instead + title <- liftIO Conf.appTitle + -- Probably going to want to do this file reading and processing at app init + homeMd <- liftIO $ mdFileToLucid "./data/base/home.md" sendLucidFragment - $ baseDoc title baseNav - <> baseHome) - -testRoute :: ResponderM a -testRoute = do - testParam <- param "testParam" - send $ status status202 $ html $ "Testing echo parameter: " <> testParam + $ baseDoc title + $ baseNav + <> baseHome homeMd missing :: ResponderM a missing = sendLucidFragment pageNotFound sendLucidFragment :: Html () -> ResponderM a -sendLucidFragment x = send $ html $ R.lucidToTwain x +sendLucidFragment x = send $ html $ lucidToTwain x diff --git a/src/Core/Rendering.hs b/src/Core/Rendering.hs index 80f4a09..85141b6 100644 --- a/src/Core/Rendering.hs +++ b/src/Core/Rendering.hs @@ -1,7 +1,20 @@ module Core.Rendering where -import Lucid -import Data.ByteString.Lazy (ByteString) +import Commonmark +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as B +import Data.Text +import Data.Text.Encoding (decodeUtf8) +import qualified Lucid as LU +import System.IO () -lucidToTwain :: Html () -> ByteString -lucidToTwain = renderBS +lucidToTwain :: LU.Html () -> ByteString +lucidToTwain = LU.renderBS + +mdToLucid :: Text -> LU.Html () +mdToLucid cmtextinput = case (commonmark "" cmtextinput) of + Left _ -> LU.toHtmlRaw ("Failed to parse Markdown document" :: Text) + Right (h :: Html ()) -> LU.toHtmlRaw (renderHtml h) + +mdFileToLucid :: FilePath -> IO (LU.Html ()) +mdFileToLucid path = fmap (mdToLucid . decodeUtf8) (B.readFile path) diff --git a/src/Fragments/Base.hs b/src/Fragments/Base.hs index 06ad501..a8e92f3 100644 --- a/src/Fragments/Base.hs +++ b/src/Fragments/Base.hs @@ -1,16 +1,18 @@ module Fragments.Base where +import Core.Rendering + import Data.Text -import Data.String (fromString) +import Data.String (fromString) import Lucid baseDoc :: String -> Html () -> Html () -baseDoc title nav = doctypehtml_ $ do +baseDoc title bodyContent = doctypehtml_ $ do head_ $ do title_ $ fromString title link_ [rel_ "stylesheet", type_ "text/css", href_ "style.css"] script_ [src_ "/htmx.min.js"] none - body_ nav + body_ bodyContent baseNav :: Html () baseNav = div_ [class_ "navContainer"] $ do @@ -20,12 +22,8 @@ baseNav = div_ [class_ "navContainer"] $ do li_ $ a_ [href_ "/contact"] "Contact" li_ $ a_ [href_ "/feed"] "Feed" -baseHome :: Html () -baseHome = div_ [class_ "main"] $ do - {- Remove the below and replace with a Markdown fragment once .md - processing is implemented. -} - h1_ "James Eversole" - p_ "A blog about functional programming, philosophy, and politics (sorry)" +baseHome :: Html () -> Html () +baseHome content = div_ [class_ "main"] content none :: Text none = mempty