Add markdown response support

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "haskell-flake": {
       "locked": {
-        "lastModified": 1728845985,
+        "lastModified": 1776783293,
-        "narHash": "sha256-0KkAWCRBNpno3f+E1rvV9TOr0iuweqncWGn1KtbrGmo=",
+        "narHash": "sha256-Na95Y2awqZsLhFNfBNbLj0hk4zyE3eKUROB2o9Qdqi8=",
         "owner": "srid",
         "repo": "haskell-flake",
-        "rev": "2393b55948866f39afcfa7d8a53893a096bcd284",
+        "rev": "f52ac89b2232dd50e5d1110416ebc5bbb09265bd",
         "type": "github"
       },
       "original": {
@@ -17,30 +17,33 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1701282334,
+        "lastModified": 1764521362,
-        "narHash": "sha256-MxCVrXY6v4QmfTwIysjjaX0XUhqBbxTWWB4HXtDYsdk=",
+        "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": {
-        "lastModified": 1727825735,
+        "lastModified": 1774748309,
-        "narHash": "sha256-0xHYkMkeLVQAMa7gvkddbPqpxph+hDzdu1XdGPJR+Os=",
+        "narHash": "sha256-+U7gF3qxzwD5TZuANzZPeJTZRHS29OFQgkQ2kiTJBIQ=",
-        "type": "tarball",
+        "owner": "nix-community",
-        "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz"
+        "repo": "nixpkgs.lib",
+        "rev": "333c4e0545a6da976206c74db8773a1645b5870a",
+        "type": "github"
       },
       "original": {
-        "type": "tarball",
+        "owner": "nix-community",
-        "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz"
+        "repo": "nixpkgs.lib",
+        "type": "github"
       }
     },
     "parts": {
@@ -48,11 +51,11 @@
         "nixpkgs-lib": "nixpkgs-lib"
       },
       "locked": {
-        "lastModified": 1727826117,
+        "lastModified": 1775087534,
-        "narHash": "sha256-K5ZLCyfO/Zj9mPFldf3iwS6oZStJcU4tSpiXTMYaaL0=",
+        "narHash": "sha256-91qqW8lhL7TLwgQWijoGBbiD4t7/q75KTi8NxjVmSmA=",
         "owner": "hercules-ci",
         "repo": "flake-parts",
-        "rev": "3d04084d54bedc3d6b8b736c70ef449225c361b1",
+        "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

@@ -15,23 +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
+                      , bytestring
-                      , clay                  >= 0.14.0
+                      , clay
-                      , commonmark            >= 0.2.4
+                      , commonmark
-                      , directory             >= 1.3.7.0
+                      , directory
-                      , dotenv                >= 0.11.0.0
+                      , dotenv
-                      , feed                  >= 1.3.2.0
+                      , feed
-                      , filemanip             >= 0.3.6.1
+                      , filemanip
-                      , filepath              >= 1.4.2.2
+                      , filepath
                       , http-types
-                      , lucid                 >= 2.11.0
+                      , lucid
-                      , text                  >= 2.0
+                      , text
-                      , time                  >= 1.12.0
+                      , time
-                      , twain                 >= 2.1.0.0
+                      , twain
-                      , wai-extra             >= 3.0 && < 3.2
+                      , wai-extra
-                      , wai-middleware-static >= 0.9.0
+                      , wai-middleware-static
-                      , warp                  == 3.3.25
+                      , warp
-                      , xml-conduit           >= 1.9.1.0
+                      , xml-conduit
     hs-source-dirs:     src
     other-modules:      Core.Configuration
                         Core.Feed

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/Feed.hs

@@ -5,9 +5,8 @@ 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
@@ -21,7 +20,7 @@ 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

src/Core/Handlers.hs

@@ -10,6 +10,7 @@ import qualified Text.Atom.Feed          as Atom
 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)
@@ -24,12 +25,16 @@ import           Web.Twain           hiding (fileName)
 -- A ResponoderM capable of lifting to IO monad; constructs response to clients
 index :: ResponderM a
 index = do
-  (title, homeMd, footerMd) <- liftIO $ (,,)
+  markdownRequested <- acceptsMarkdown
-    <$> Conf.title
+  if markdownRequested
-    <*> mdFileToLucid "./data/posts/home.md"
+    then sendMarkdownFile "./data/posts/home.md"
-    <*> mdFileToLucid "./data/posts/footer.md"
+    else do
-  -- Respond to request with fragments compositionally to create a home page
+      (title, homeMd, footerMd) <- liftIO $ (,,)
-  sendLucidFragment $ basePage title (baseHome homeMd) footerMd
+        <$> 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
 posts :: ResponderM a
@@ -39,11 +44,15 @@ posts = do
   case postValid of
     False  -> missing
     True   -> do
-      (title, footerMd, postMd) <- liftIO $ (,,)
+      markdownRequested <- acceptsMarkdown
-        <$> Conf.title
+      if markdownRequested
-        <*> mdFileToLucid "./data/posts/footer.md"
+        then sendMarkdownFile $ postPath postName
-        <*> (mdFileToLucid $ postPath postName)
+        else do
-      sendLucidFragment $ basePage title (basePost postMd) footerMd
+          (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
@@ -104,16 +113,33 @@ feed = do
 -- Refer to index comments
 contact :: ResponderM a
 contact = do
-  (title, contactMd, footerMd) <- liftIO $ (,,)
+  markdownRequested <- acceptsMarkdown
-    <$> Conf.title
+  if markdownRequested
-    <*> mdFileToLucid "./data/posts/contact.md"
+    then sendMarkdownFile "./data/posts/contact.md"
-    <*> mdFileToLucid "./data/posts/footer.md"
+    else do
-  sendLucidFragment   $ basePage title (baseContact contactMd) footerMd
+      (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
 sendLucidFragment x = send $ html $ lucidToTwain x

src/Core/Rendering.hs

@@ -20,6 +20,9 @@ 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