From 3172ca2f595a60c3d88ebf47527b07162960125e Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 23 Apr 2026 10:53:56 -0500 Subject: [PATCH] Add markdown response support --- flake.lock | 35 +++++++++++--------- flake.nix | 4 +-- sampu.cabal | 32 +++++++++--------- scratch/tricu.cabal | 75 +++++++++++++++++++++++++++++++++++++++++++ src/Core/Feed.hs | 5 ++- src/Core/Handlers.hs | 58 ++++++++++++++++++++++++--------- src/Core/Rendering.hs | 3 ++ 7 files changed, 159 insertions(+), 53 deletions(-) create mode 100644 scratch/tricu.cabal diff --git a/flake.lock b/flake.lock index 2a4f817..79c7616 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "haskell-flake": { "locked": { - "lastModified": 1728845985, - "narHash": "sha256-0KkAWCRBNpno3f+E1rvV9TOr0iuweqncWGn1KtbrGmo=", + "lastModified": 1776783293, + "narHash": "sha256-Na95Y2awqZsLhFNfBNbLj0hk4zyE3eKUROB2o9Qdqi8=", "owner": "srid", "repo": "haskell-flake", - "rev": "2393b55948866f39afcfa7d8a53893a096bcd284", + "rev": "f52ac89b2232dd50e5d1110416ebc5bbb09265bd", "type": "github" }, "original": { @@ -17,30 +17,33 @@ }, "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": { - "lastModified": 1727825735, - "narHash": "sha256-0xHYkMkeLVQAMa7gvkddbPqpxph+hDzdu1XdGPJR+Os=", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" + "lastModified": 1774748309, + "narHash": "sha256-+U7gF3qxzwD5TZuANzZPeJTZRHS29OFQgkQ2kiTJBIQ=", + "owner": "nix-community", + "repo": "nixpkgs.lib", + "rev": "333c4e0545a6da976206c74db8773a1645b5870a", + "type": "github" }, "original": { - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" + "owner": "nix-community", + "repo": "nixpkgs.lib", + "type": "github" } }, "parts": { @@ -48,11 +51,11 @@ "nixpkgs-lib": "nixpkgs-lib" }, "locked": { - "lastModified": 1727826117, - "narHash": "sha256-K5ZLCyfO/Zj9mPFldf3iwS6oZStJcU4tSpiXTMYaaL0=", + "lastModified": 1775087534, + "narHash": "sha256-91qqW8lhL7TLwgQWijoGBbiD4t7/q75KTi8NxjVmSmA=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "3d04084d54bedc3d6b8b736c70ef449225c361b1", + "rev": "3107b77cd68437b9a76194f0f7f9c55f2329ca5b", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 9fcfb33..115a251 100644 --- a/flake.nix +++ b/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; diff --git a/sampu.cabal b/sampu.cabal index a36b2f7..d6cf539 100644 --- a/sampu.cabal +++ b/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 - , clay >= 0.14.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 + , bytestring + , clay + , commonmark + , directory + , dotenv + , feed + , filemanip + , filepath , http-types - , 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 + , lucid + , text + , time + , twain + , wai-extra + , wai-middleware-static + , warp + , xml-conduit hs-source-dirs: src other-modules: Core.Configuration Core.Feed diff --git a/scratch/tricu.cabal b/scratch/tricu.cabal new file mode 100644 index 0000000..8bd6232 --- /dev/null +++ b/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 diff --git a/src/Core/Feed.hs b/src/Core/Feed.hs index 4d5e865..61b8cdc 100644 --- a/src/Core/Feed.hs +++ b/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 diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs index 8082117..03a65fa 100644 --- a/src/Core/Handlers.hs +++ b/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 $ (,,) - <$> 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 + 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 posts :: ResponderM a @@ -39,11 +44,15 @@ posts = do case postValid of False -> missing True -> do - (title, footerMd, postMd) <- liftIO $ (,,) - <$> Conf.title - <*> mdFileToLucid "./data/posts/footer.md" - <*> (mdFileToLucid $ postPath postName) - sendLucidFragment $ basePage title (basePost postMd) footerMd + 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 @@ -104,16 +113,33 @@ feed = do -- Refer to index comments contact :: ResponderM a contact = do - (title, contactMd, footerMd) <- liftIO $ (,,) - <$> Conf.title - <*> mdFileToLucid "./data/posts/contact.md" - <*> mdFileToLucid "./data/posts/footer.md" - sendLucidFragment $ basePage title (baseContact contactMd) footerMd + 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 sendLucidFragment x = send $ html $ lucidToTwain x diff --git a/src/Core/Rendering.hs b/src/Core/Rendering.hs index 8eb5bbc..b0257d9 100644 --- a/src/Core/Rendering.hs +++ b/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