Add markdown response support

README.md

@@ -1,6 +1,6 @@
 # the sampu Haskell blog engine
 
-https://eversole.co (not live yet!)
+https://eversole.co
 
 a _work-in-progress_ blog engine using simple flat-file Markdown content storage
 
@@ -14,18 +14,46 @@ Therefore, `la sampu cu sampu lo ka samtci`!
 
 - [Haskell](https://www.haskell.org)
 - [Twain](https://github.com/alexmingoia/twain)
-- [Lucid2](https://chrisdone.com/posts/lucid2)
+- [Lucid](https://github.com/chrisdone/lucid)
+- [Clay](https://github.com/sebastiaanvisser/clay)
 
 ## Goal
 
 Provide a simple blog engine that is easily customizable via HTML fragments.
 
-## Deployment
+## Build and Deployment
 
-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.
+Only Nix build instructions are provided below.
 
+### No Containers
+1) Clone this repository
+2) Build the application (with flakes enabled): `nix build '.#'`
+3) Set the environment variables
+    - File: `cp data/.env.example ./.env; $EDITOR ./.env`
+    - If you want to set them in a different way, you already know how.
+4) Run the application: `./result/bin/sampu`
+
+### Containers
+
+1) Clone this repository
+2) Build the container image (with flakes enabled): `nix build .#sampu-container`
+3) Load the container image: `podman load -i result`
+4) Run the container using your favorite orchestrator or...
+5) Use a NixOS configuration:
+```
+virtualisation.oci-containers.containers.sampu = {
+  image = "sampu";
+  ports = [ "${SAMPUR_EXTERNAL_PORT}:3000" ];
+  volumes = [
+    "/PATH/TO/SAMPU/data:/app/data"
+  ];
+  environment = {
+    SAMPU_PORT = "3000";
+    SAMPU_TITLE = "Your Blog Title Here!";
+    SAMPU_BASEURL = "http://example.public.tld"; 
+  };
+};
+```
 ## Development and Support
 
 Per the permissive ISC license, you are free to do what you wish with this 

data/.env.example

@@ -1,2 +1,3 @@
-APPLICATIONPORT="3000"
-BLOGTITLE="Anon's Blog"
+SAMPU_PORT="3000"
+SAMPU_TITLE="Anon's Blog"
+SAMPU_BASEURL="http://localhost:3000"

data/assets/public/style.css

@@ -1,61 +0,0 @@
-html{font-family:Monospace;background-color:#f1f6f0;color:#222323}
-a{text-decoration:none}
-h2{text-transform:uppercase}
-h3{margin:0.25em 0 0.25em 0}
-p{margin:0.4em 0 0.4em 0}
-a{color:#6D92AD}
-
-body {
-  margin: 1% 2%;
-  font-size: 1.25em;
-  font-weight: 300;
-  text-align: left
-}
-
-body li {
-  list-style-type: "~> ";
-}
-
-.main {
-  margin: 1em auto;
-  max-width: 60%;
-}
-
-.navContainer {
-  width: 100%;
-  text-align: center;
-}
-
-.mainNav {
-  margin: 0 auto;
-  padding: 0;
-  overflow: hidden;
-  box-shadow: 4px 4px 6px #ccc;
-  display: inline-flex;
-}
-
-.mainNav li {
-  list-style-type: none;
-}
-
-.mainNav li a {
-  display: block;
-  text-align: center;
-  padding: 0.25em 0.3em;
-  text-transform: lowercase;
-}
-
-.notFound {
-  margin: 0 auto;
-  text-align: center;
-}
-
-.notFound h1 {
-  font-size: 500%;
-  font-weight: 200;
-  color:#6D92AD
-}
-
-.postList {
-  font-size: 1.5em;
-}

data/posts/footer.md.example

@@ -0,0 +1 @@
+Copyright [Your Name](youremail@address.local)

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "haskell-flake": {
       "locked": {
-        "lastModified": 1707835791,
-        "narHash": "sha256-oQbDPHtver9DO8IJCBMq/TVbscCkxuw9tIfBBti71Yk=",
+        "lastModified": 1776783293,
+        "narHash": "sha256-Na95Y2awqZsLhFNfBNbLj0hk4zyE3eKUROB2o9Qdqi8=",
         "owner": "srid",
         "repo": "haskell-flake",
-        "rev": "5113f700d6e92199fbe0574f7d12c775bb169702",
+        "rev": "f52ac89b2232dd50e5d1110416ebc5bbb09265bd",
         "type": "github"
       },
       "original": {
@@ -17,35 +17,32 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1701282334,
-        "narHash": "sha256-MxCVrXY6v4QmfTwIysjjaX0XUhqBbxTWWB4HXtDYsdk=",
+        "lastModified": 1764521362,
+        "narHash": "sha256-M101xMtWdF1eSD0xhiR8nG8CXRlHmv6V+VoY65Smwf4=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "057f9aecfb71c4437d2b27d3323df7f93c010b7e",
+        "rev": "871b9fd269ff6246794583ce4ee1031e1da71895",
         "type": "github"
       },
       "original": {
         "owner": "nixos",
-        "ref": "23.11",
+        "ref": "25.11",
         "repo": "nixpkgs",
         "type": "github"
       }
     },
     "nixpkgs-lib": {
       "locked": {
-        "dir": "lib",
-        "lastModified": 1706550542,
-        "narHash": "sha256-UcsnCG6wx++23yeER4Hg18CXWbgNpqNXcHIo5/1Y+hc=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "97b17f32362e475016f942bbdfda4a4a72a8a652",
+        "lastModified": 1774748309,
+        "narHash": "sha256-+U7gF3qxzwD5TZuANzZPeJTZRHS29OFQgkQ2kiTJBIQ=",
+        "owner": "nix-community",
+        "repo": "nixpkgs.lib",
+        "rev": "333c4e0545a6da976206c74db8773a1645b5870a",
         "type": "github"
       },
       "original": {
-        "dir": "lib",
-        "owner": "NixOS",
-        "ref": "nixos-unstable",
-        "repo": "nixpkgs",
+        "owner": "nix-community",
+        "repo": "nixpkgs.lib",
         "type": "github"
       }
     },
@@ -54,11 +51,11 @@
         "nixpkgs-lib": "nixpkgs-lib"
       },
       "locked": {
-        "lastModified": 1706830856,
-        "narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=",
+        "lastModified": 1775087534,
+        "narHash": "sha256-91qqW8lhL7TLwgQWijoGBbiD4t7/q75KTi8NxjVmSmA=",
         "owner": "hercules-ci",
         "repo": "flake-parts",
-        "rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f",
+        "rev": "3107b77cd68437b9a76194f0f7f9c55f2329ca5b",
         "type": "github"
       },
       "original": {

flake.nix

@@ -1,6 +1,6 @@
 {
   inputs = {
-    nixpkgs.url = "github:nixos/nixpkgs/23.11";
+    nixpkgs.url = "github:nixos/nixpkgs/25.11";
     haskell-flake.url = "github:srid/haskell-flake";
     parts.url = "github:hercules-ci/flake-parts";
   };
@@ -17,7 +17,7 @@
         haskellProjects.default = {
           basePackages = pkgs.haskellPackages;
           packages = {
-            http2.source = "3.0.3";
+            http2.source = "5.3.10";
           };
           devShell = {
            enable = true;

sampu.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            sampu
-version:         0.3.0
+version:         0.10.0
 license:         ISC
 author:          James Eversole
 maintainer:      james@eversole.co
@@ -15,21 +15,23 @@ executable sampu
     default-extensions: OverloadedStrings
     ghc-options:        -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
     build-depends:      base
-                      , bytestring            >= 0.11.5.0
-                      , 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
+                      , bytestring
+                      , clay
+                      , commonmark
+                      , directory
+                      , dotenv
+                      , feed
+                      , filemanip
+                      , filepath
+                      , http-types
+                      , lucid
+                      , text
+                      , time
+                      , twain
+                      , wai-extra
+                      , wai-middleware-static
+                      , warp
+                      , xml-conduit
     hs-source-dirs:     src
     other-modules:      Core.Configuration
                         Core.Feed
@@ -37,5 +39,5 @@ executable sampu
                         Core.HTTP
                         Core.Rendering
                         Fragments.Base
-                        Fragments.NotFound
+                        Fragments.Styles
     default-language:   GHC2021

scratch/tricu.cabal

@@ -0,0 +1,75 @@
+cabal-version: 1.12
+
+name:           tricu
+version:        0.19.0
+description:    A micro-language for exploring Tree Calculus
+author:         James Eversole
+maintainer:     james@eversole.co
+copyright:      James Eversole
+license:        ISC
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+
+executable tricu
+  main-is: Main.hs
+  hs-source-dirs:
+      src
+  default-extensions:
+      DeriveDataTypeable
+      LambdaCase
+      MultiWayIf
+      OverloadedStrings
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
+  build-depends:
+    base >=4.7
+    , cmdargs
+    , containers
+    , exceptions
+    , filepath
+    , haskeline
+    , megaparsec
+    , mtl
+    , text
+    , transformers
+  other-modules:
+    Eval
+    FileEval
+    Lexer
+    Parser
+    REPL
+    Research
+  default-language: Haskell2010
+
+test-suite tricu-tests
+  type:                exitcode-stdio-1.0
+  main-is:             Spec.hs
+  hs-source-dirs:      test, src
+  default-extensions:
+      DeriveDataTypeable
+      LambdaCase
+      MultiWayIf
+      OverloadedStrings
+  build-depends:       
+    base
+    , cmdargs
+    , containers
+    , exceptions
+    , filepath
+    , haskeline
+    , megaparsec
+    , mtl
+    , tasty
+    , tasty-hunit
+    , tasty-quickcheck
+    , text
+    , transformers
+  default-language:    Haskell2010
+  other-modules:
+    Eval
+    FileEval
+    Lexer
+    Parser
+    REPL
+    Research

src/Core/Configuration.hs

@@ -35,11 +35,17 @@ main = do
       ++ "All required environment variables:\n"
       ++  unlines required
 
-appPort :: IO String
-appPort = getEnv "APPLICATIONPORT"
+-- The port to run the web server on
+port :: IO String
+port = getEnv "SAMPU_PORT"
 
-appTitle :: IO String
-appTitle = getEnv "BLOGTITLE"
+-- The site's title; used for HTML title and XML feed title
+title :: IO String
+title = getEnv "SAMPU_TITLE"
+
+-- The site's public-facing base url with no trailing slash
+baseUrl :: IO String
+baseUrl = getEnv "SAMPU_BASEURL"
 
 requiredEnvVars :: [String]
-requiredEnvVars = [ "APPLICATIONPORT", "BLOGTITLE" ]
+requiredEnvVars = [ "SAMPU_PORT", "SAMPU_TITLE", "SAMPU_BASEURL" ]

src/Core/Feed.hs

@@ -5,12 +5,12 @@ 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 qualified Text.Feed.Export as Export (textFeed)
 import           Text.Feed.Types
-import           Text.XML (def, rsPretty)
 
 data Post = Post { _date     :: Text
                  , _url      :: Text
+                 , _title    :: Text
                  , _content  :: Text
                  }
 
@@ -20,8 +20,11 @@ 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
+renderFeed = fromJust . Export.textFeed . AtomFeed
 
 -- Convert a Post to an Atom Entry
 toEntry :: Post -> Atom.Entry
-toEntry (Post date url content) = (Atom.nullEntry url (Atom.TextString content) date)
+toEntry (Post date url title content) = (Atom.nullEntry url (Atom.TextString title) date)
+  { Atom.entryLinks = [Atom.nullLink url]
+  , Atom.entryContent = Just (Atom.HTMLContent content)
+  }

src/Core/HTTP.hs

@@ -6,48 +6,41 @@ import qualified Core.Handlers                        as Handle
 import           Control.Monad                        ( mapM_ )
 import           Data.String                          ( fromString )
 import           Network.Wai.Handler.Warp             ( Port, run )
-import           Network.Wai.Middleware.RequestLogger ( logStdoutDev )
-import           Network.Wai.Middleware.Static
+import           Network.Wai.Middleware.RequestLogger ( logStdout, logStdoutDev )
+import           Network.Wai.Middleware.Static        ( staticPolicy, noDots, addBase, (>->) )
 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
-  port <- Conf.appPort
+main :: IO ()
+main = do
+  port <- Conf.port
   let app = preProcessors
-         ++ (routes postNames)
+         ++ routes
          ++ postProcessors
   run (read port) $
     foldr ($) (notFound Handle.missing) app
 
 -- These Middlewares are executed before any routes are reached.
 preProcessors :: [Middleware]
-preProcessors = [ logStdoutDev
-                , staticPolicy $ noDots >-> addBase "data/assets/public"
-                ]
+preProcessors  = [ logStdoutDev
+                 , staticPolicy (noDots >-> addBase "data/assets/public")
+                 ]
 
 -- These Middlewares are executed after all other routes are exhausted
 postProcessors :: [Middleware]
-postProcessors = []
+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  =
-  [ get "/"         Handle.index 
-  , get "/posts"  $ Handle.postsIndex postNames
-  ] ++ (buildMdRoutes postNames) ++ 
-  [ get "/contact"  Handle.contact
-  , get "/feed"   $ Handle.feed postNames
+-- Core routes expressed as a list of WAI Middlewares.
+routes :: [Middleware]
+routes =
+  [ get "/"            Handle.index
+  , 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
   ]
-
--- 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

src/Core/Handlers.hs

@@ -1,82 +1,144 @@
 module Core.Handlers where
 
 import qualified Core.Configuration      as Conf
+import           Core.Feed                  (Post(..), autoFeed, renderFeed)
 import           Core.Rendering
-import           Core.Feed               (Post(..), autoFeed, renderFeed)
 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           Data.ByteString.Lazy       (ByteString)
+import qualified Data.Text               as T
+import qualified Data.Text.Lazy          as LT
+import qualified Data.Text.Lazy.Encoding as TLE
+import           Data.Time.Clock            (UTCTime(..), getCurrentTime)
+import           Data.Time.Format           (formatTime, defaultTimeLocale)
+import           Lucid                      (Html)
+import           Network.HTTP.Types         (status200, hContentType)
+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
 index = do
-  -- Query the system environment for the BLOGTITLE environment variable
-  title  <- liftIO Conf.appTitle
-  -- 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)
+  markdownRequested <- acceptsMarkdown
+  if markdownRequested
+    then sendMarkdownFile "./data/posts/home.md"
+    else do
+      (title, homeMd, footerMd) <- liftIO $ (,,)
+        <$> Conf.title
+        <*> mdFileToLucid "./data/posts/home.md"
+        <*> mdFileToLucid "./data/posts/footer.md"
+      -- 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.appTitle
-  postMd <- liftIO  $ mdFileToLucid ("./data/posts/" ++ postName ++ ".md")
-  sendLucidFragment $ basePage title (basePost postMd)
+-- 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
+      markdownRequested <- acceptsMarkdown
+      if markdownRequested
+        then sendMarkdownFile $ postPath postName
+        else do
+          (title, footerMd, postMd) <- liftIO $ (,,)
+            <$> Conf.title
+            <*> mdFileToLucid "./data/posts/footer.md"
+            <*> (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.appTitle
-  sendLucidFragment $ basePage title (postIndex postNames)
+      postPath :: T.Text -> FilePath
+      postPath postName = "./data/posts/" ++ T.unpack postName ++ ".md"
+
+-- Builds an index of all posts
+postsIndex :: ResponderM a
+postsIndex = do
+  (postNames, title, footerMd) <- liftIO $ (,,)
+    <$> mdPostNames
+    <*> Conf.title
+    <*> mdFileToLucid "./data/posts/footer.md"
+  sendLucidFragment $ basePage title (postIndex postNames) footerMd
 
 -- 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
+feed :: ResponderM a
+feed = do
+  (postNames, title, baseUrl, time) <- liftIO $ (,,,)
+    <$> mdPostNames
+    <*> Conf.title
+    <*> Conf.baseUrl
+    <*> fmap (\x -> timeFormat x) getCurrentTime
+  feedData <- liftIO $ mapM (makePost baseUrl) postNames
   -- Send an XML response with an automatically populated Atom feed
-  send $ xml $ LTE.encodeUtf8 $ renderFeed 
-       $ autoFeed (baseFeed title time) feedData
+  send $ atom 
+       $ TLE.encodeUtf8 
+       $ renderFeed
+       $ autoFeed (baseFeed title time baseUrl) feedData
     where
+      -- Atom feed response headers
+      atom :: ByteString -> Response
+      atom f = withHeader (hContentType, "application/atom+xml") $ raw status200 [] $ f
+
       -- 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")
+      baseFeed :: String -> String -> String -> Atom.Feed
+      baseFeed title time baseUrl = Atom.nullFeed
+        (T.pack $ baseUrl ++ "/feed")
+        (Atom.TextString $ T.pack title)
+        (T.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"
+      makePost :: String -> FilePath -> IO (Post)
+      makePost baseUrl postName = do
+        date <- getModificationTime $ "./data/posts/" ++ postName ++ ".md"
+        postContent <- mdFileToText $ "./data/posts/" ++ postName ++ ".md"
         return  $ Post
-          (pack $ (timeFormat date) ++ " UTC")
-          (pack $ "https://eversole.co/posts/" ++ x) 
-          (pack $ show x)
+          (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
       timeFormat :: UTCTime -> String
-      timeFormat x = formatTime defaultTimeLocale "%Y-%m-%d %H:%M" x
+      timeFormat date = formatTime defaultTimeLocale "%Y-%m-%d %H:%M" date
 
 -- 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)
+  markdownRequested <- acceptsMarkdown
+  if markdownRequested
+    then sendMarkdownFile "./data/posts/contact.md"
+    else do
+      (title, contactMd, footerMd) <- liftIO $ (,,)
+        <$> Conf.title
+        <*> mdFileToLucid "./data/posts/contact.md"
+        <*> mdFileToLucid "./data/posts/footer.md"
+      sendLucidFragment $ basePage title (baseContact contactMd) footerMd
 
+-- Respond with primary processed CSS
+theme :: ResponderM a
+theme = send $ css $ TLE.encodeUtf8 $ S.cssRender S.composedStyles
+
+acceptsMarkdown :: ResponderM Bool
+acceptsMarkdown = do
+  acceptHeader <- header "Accept"
+  return $ maybe False (T.isInfixOf "text/markdown" . T.toLower) acceptHeader
+
+sendMarkdownFile :: FilePath -> ResponderM a
+sendMarkdownFile path = do
+  markdown <- liftIO $ mdFileToMarkdown path
+  send $ withHeader (hContentType, "text/markdown; charset=utf-8")
+       $ raw status200 []
+       $ TLE.encodeUtf8
+       $ LT.fromStrict markdown
 
 -- Helper function for responding in ResponderM from Html
 sendLucidFragment :: Html () -> ResponderM a
@@ -85,3 +147,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

src/Core/Rendering.hs

@@ -5,6 +5,7 @@ import           Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString      as B
 import           Data.Text
 import           Data.Text.Encoding   (decodeUtf8)
+import           Data.Text.Lazy       (toStrict)
 import qualified Lucid                as LU
 import           System.IO            ()
 
@@ -18,3 +19,11 @@ mdToLucid cmtextinput = case (commonmark "" cmtextinput) of
 
 mdFileToLucid :: FilePath -> IO (LU.Html ())
 mdFileToLucid path = fmap (mdToLucid . decodeUtf8) (B.readFile path)
+
+mdFileToMarkdown :: FilePath -> IO Text
+mdFileToMarkdown path = fmap decodeUtf8 (B.readFile path)
+
+mdFileToText :: FilePath -> IO (Text)
+mdFileToText path = do
+  htmlContent <- mdFileToLucid path
+  return $ toStrict $ LU.renderText htmlContent

src/Fragments/Base.hs

@@ -15,10 +15,9 @@ baseDoc title bodyContent = doctypehtml_ $ do
     link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css"]
   body_ bodyContent
 
-baseFeed :: Html ()
-baseFeed = div_ [class_ "main"] $ do
-  h2_ "Oops, I haven't been implemented yet." 
-  h3_ "Check back in a couple days!"
+baseFooter :: Html () -> Html ()
+baseFooter content = footer_ $ do
+  p_ $ content
 
 baseHome :: Html () -> Html ()
 baseHome content = div_ [class_ "main"] content
@@ -31,19 +30,24 @@ baseNav = div_ [class_ "navContainer"] $ do
     li_ $ a_ [href_ "/contact"] "Contact"
     li_ $ a_ [href_ "/feed"]    "Feed"
 
-basePage :: String -> Html () -> Html()
-basePage title body = baseDoc title $ baseNav <> body
+basePage :: String -> Html () -> Html () -> Html ()
+basePage title body footer = baseDoc title $ baseNav <> body <> baseFooter footer
 
 basePost :: Html () -> Html ()
 basePost content = div_ [class_ "main"] content
 
 postIndex :: [FilePath] -> Html ()
-postIndex postNames = div_ [class_ "main"] $ do
+postIndex postNames = div_ [class_ "postList"] $ do
   h1_ [class_ "title"] "All Posts"
-  ul_ [class_ "postList"] $ do
+  ul_ [] $ do
     mapM_
       (\x -> li_ $ a_ [href_ (pack $ "/posts/" ++ x)] (fromString x))
       postNames
 
+pageNotFound :: Html ()
+pageNotFound = baseDoc "404" baseNav <>
+  (div_ [class_ "notFound"] $ h1_ "404 NOT FOUND")
+
 none :: Text
 none = mempty
+

src/Fragments/NotFound.hs

@@ -1,9 +0,0 @@
-module Fragments.NotFound where
-
-import Fragments.Base 
-
-import Lucid
-
-pageNotFound :: Html ()
-pageNotFound = baseDoc "404" baseNav <>
-  (div_ [class_ "notFound"] $ h1_ "404 NOT FOUND")

src/Fragments/Styles.hs

@@ -0,0 +1,150 @@
+module Fragments.Styles where
+
+import           Clay           hiding (main_)
+import qualified Clay.Media     as M
+import           Data.Text.Lazy hiding (center)
+import           Prelude        hiding (div)
+
+cssRender :: Css -> Text
+cssRender css = renderWith compact [] css
+
+priColor, secColor, terColor :: Color
+priColor = "#f1f6f0"
+secColor = "#222323"
+terColor = "#6D92AD"
+
+composedStyles :: Css
+composedStyles = do
+  core_
+  main_
+  nav_
+  notFound_
+  postList_
+  mobileFriendly_
+
+core_ :: Css
+core_ = do
+  a_
+  body_
+  code_
+  footer_
+  html_
+  p_
+  pre_
+
+a_ :: Css
+a_ = do
+  a ? do
+    textDecoration    none
+    color             terColor
+
+body_ :: Css
+body_ = do
+  body ? do
+    display       flex
+    minHeight   $ vh 100
+    flexDirection column
+    fontFamily    [] [monospace]
+    fontSize    $ em 1.25
+    fontWeight  $ weight 300
+    textAlign     start
+    margin        (em 0) auto (em 0) auto
+    strong ? do
+      fontWeight    $ weight 600
+    li ? do
+      listStyleType $ other "\"~> \""
+
+footer_ :: Css
+footer_ = do
+  footer ? do
+    bottom            (em 0)
+    margin            auto (em 0) (em 0) (em 0)
+    width           $ pct 100
+    backgroundColor   terColor
+    textAlign         center
+    padding           (em 1) (em 0) (em 1) (em 0)
+    boxSizing         borderBox
+    p ? do
+      fontSize $ em 0.75
+      margin     (em 0) (em 2) (em 0) (em 2)
+      color      priColor
+      a ? do
+        color priColor
+
+html_ :: Css
+html_ = do
+  html   ? do
+    backgroundColor priColor
+    color           secColor
+
+p_ :: Css
+p_ = do
+  p ? do
+    margin (em 1) (em 0) (em 0.6) (em 0)
+
+main_ :: Css
+main_ = do
+  ".main" ? do
+    margin     (em 0) auto (em 2) auto
+    width    $ pct 60
+
+notFound_ :: Css
+notFound_ = do
+  ".notFound" ? do
+    margin    (em 0) auto (em 0) auto
+    textAlign center
+    h1 ? do
+      fontSize   $ pct 500
+      fontWeight $ weight 200
+      color        terColor
+
+postList_ :: Css
+postList_ = do
+  ".postList" ? do
+    margin   (em 0) auto (em 0) auto
+    minWidth (pct 60)
+    maxWidth (pct 95)
+    overflow scroll
+    ul ? do
+      fontSize (em 1.5)
+
+code_ :: Css
+code_ = do
+  code ? do
+    color           priColor
+    backgroundColor terColor
+    overflowX       scroll
+
+pre_ :: Css
+pre_ = do
+  pre ? do
+    color           priColor
+    backgroundColor terColor
+    overflowX       scroll
+
+nav_ :: Css
+nav_ = do
+  ".navContainer" ? do
+    margin      (em 1.5) (em 0) (em 1.5) (em 0)
+    width     $ pct 100
+    textAlign   center
+  ".mainNav"      ? do
+    margin      (em 0) auto (em 0) auto
+    padding     (em 0.5) (em 0.5) (em 0.5) (em 0.5)
+    overflow    hidden
+    boxShadow . pure $ bsColor "#ccc" $ shadowWithBlur (px 4) (px 4) (px 6)
+    display     inlineFlex
+    li ? do
+      listStyleType   none
+      a ? do
+        display       block
+        textAlign     center
+        padding       (em 0.25) (em 0.3) (em 0.25) (em 0.3)
+        textTransform lowercase
+
+mobileFriendly_ :: Css
+mobileFriendly_ = query M.screen [M.maxWidth 768] $ do
+  ".main" ? do
+    width $ pct 95
+  ".postList" ? do
+    width $ pct 95

src/Main.hs

@@ -3,26 +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"
-    fileFilter = isMdFile &&? isVisible &&? isHome &&? isContact
+  HTTP.main