From b775fd4f3ff9dfbb74542dc16c59eb9253d58c44 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Tue, 19 May 2026 07:12:14 -0400 Subject: [PATCH] Recipe detail page with server-side HTML rendering MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add Roux.Html.recipePage: full recipe detail page with: - Back navigation link - Title and metadata (servings, times, difficulty, etc.) - Ingredients summary list with quantities - Sections with named headings - Steps with inline element rendering: - Ingredients highlighted in pumpkin (with quantity badge) - Cookware in violet italic - Timers in azure with ⏱ icon - Comments in sand italic - Recipe refs as links - Line breaks - Update Roux.Server: route /recipes/FILENAME to recipe page - Case-insensitive filename lookup, .cook extension optional - URL decoding for filenames - Fix ingredient name parsing: restrict name characters to alphaNum + spaces/hyphens/apostrophes, preventing greedy consumption across special chars like ) and # - Split name chars into pMultiNameChar (with spaces, before braces) and pSingleNameChar (without spaces, fallback) - Suppress -Wname-shadowing in Html.hs (blaze-html exports clash with common variable names) - All 26 tests passing, server smoke-tested with examples --- src/Roux/Html.hs | 316 +++++++++++++++++++++++++++++++++++++++++---- src/Roux/Parser.hs | 22 +++- src/Roux/Server.hs | 31 ++++- 3 files changed, 339 insertions(+), 30 deletions(-) diff --git a/src/Roux/Html.hs b/src/Roux/Html.hs index 5305c71..7047c39 100644 --- a/src/Roux/Html.hs +++ b/src/Roux/Html.hs @@ -1,12 +1,25 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + {- | HTML rendering for the Roux web interface. -Uses blaze-html directly. Styling via Pico CSS (inlined in the page). +Uses blaze-html directly. Styling via Pico CSS. + +Blaze-html re-exports many common names (title, meta, step, a, b, …) +so name-shadowing is unavoidable with local bindings. -} module Roux.Html ( indexPage, + recipePage, + urlEncode, + urlDecode, ) where +import Control.Monad (unless) import Data.ByteString.Lazy (ByteString) +import Data.Function ((&)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (catMaybes) +import Data.Ratio (denominator, numerator) import Data.Text (Text) import qualified Data.Text as T import qualified Text.Blaze.Html.Renderer.Utf8 as R @@ -14,35 +27,266 @@ import Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes as A import qualified Roux.RecipeIndex as Idx +import Roux.Types --- | Render the recipe index page. -indexPage :: [Idx.RecipeInfo] -> ByteString -indexPage recipes = +-- --------------------------------------------------------------------------- +-- Helpers used throughout +-- --------------------------------------------------------------------------- + +-- | Pair a label with a value if present. +pairWith :: a -> Maybe b -> Maybe (a, b) +pairWith _ Nothing = Nothing +pairWith a (Just b) = Just (a, b) + +-- | Format a quantity for display. +showQuantity :: Quantity -> Text +showQuantity q = + let amt = quantityAmount q + amount = case denominator amt of + 1 -> T.pack (show (numerator amt)) + _ -> T.pack (show (toDouble amt)) + prefix = if quantityFixed q then "=" else "" + unit = maybe "" (\u -> "%" <> u) (quantityUnit q) + in prefix <> amount <> unit + +-- --------------------------------------------------------------------------- +-- Page shell +-- --------------------------------------------------------------------------- + +-- | Wrap content in a full HTML5 page with Pico CSS. +page :: Text -> Html -> ByteString +page title content = R.renderHtml $ H.docTypeHtml $ do H.head $ do H.meta ! A.charset "utf-8" H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1" - H.title "Roux — Recipes" + H.title (H.toHtml title) H.link ! A.rel "stylesheet" ! A.href "https://cdn.jsdelivr.net/npm/@picocss/pico@2/css/pico.min.css" - H.body $ do - H.main ! A.class_ "container" $ do - H.h1 "Roux" - H.p "Your personal recipe collection." - H.h2 "Recipes" - H.ul $ mapM_ recipeItem recipes + H.style + "main.container { padding-top: 2rem; } \ + \.roux-ingredient { color: var(--pico-color-pumpkin); } \ + \.roux-cookware { color: var(--pico-color-violet); font-style: italic; } \ + \.roux-timer { color: var(--pico-color-azure); } \ + \.roux-comment { color: var(--pico-color-sand); font-style: italic; } \ + \.roux-break { display: block; } \ + \.tag { display: inline-block; background: var(--pico-contrast-background); \ + \padding: 0.1rem 0.5rem; margin: 0.1rem; border-radius: 4px; font-size: 0.8rem; }" + H.body $ H.main ! A.class_ "container" $ content --- | Render a single recipe list item. -recipeItem :: Idx.RecipeInfo -> Html -recipeItem info = - H.li $ case Idx.riRecipe info of - Left _err -> - H.span ! A.class_ "error" $ do - H.toHtml (Idx.riTitle info) - " (parse error)" - Right _recipe -> - H.a ! A.href (H.toValue ("/recipes/" <> urlEncode (Idx.riFilename info))) $ - H.toHtml (Idx.riTitle info) +-- --------------------------------------------------------------------------- +-- Index page +-- --------------------------------------------------------------------------- + +-- | Render the recipe index page. +indexPage :: [Idx.RecipeInfo] -> ByteString +indexPage recipes = + page "Roux — Recipes" $ do + H.nav $ H.ul $ H.li $ H.strong "Roux" + H.h2 "Recipes" + H.p "Your personal recipe collection." + case filter (isRight . Idx.riRecipe) recipes of + [] -> H.p "No recipes found." + good -> + H.ul $ mapM_ (recipeItem . Idx.riFilename) good + -- Show parse errors separately + let bad = filter (isLeft . Idx.riRecipe) recipes + unless (null bad) $ do + H.h3 "Unparseable recipes" + H.ul $ mapM_ (\r -> H.li $ H.toHtml (Idx.riTitle r)) bad + +-- | Render a single recipe link on the index page. +recipeItem :: FilePath -> Html +recipeItem fp = + H.li $ + H.a ! A.href (H.toValue ("/recipes/" <> urlEncode fp)) $ + H.toHtml (T.pack (takeBaseName fp)) + +-- --------------------------------------------------------------------------- +-- Recipe detail page +-- --------------------------------------------------------------------------- + +-- | Render a full recipe detail page. +recipePage :: Idx.RecipeInfo -> ByteString +recipePage info = + case Idx.riRecipe info of + Left err -> + page "Parse Error" $ do + H.nav $ H.ul $ H.li $ H.a ! A.href "/" $ "← Back" + H.h2 "Parse Error" + H.p $ H.toHtml (Idx.riTitle info <> ": " <> T.pack err) + Right recipe -> + page (titleText recipe) $ + renderRecipe recipe + +-- | Render the body of a recipe page (no page shell). +renderRecipe :: Recipe -> Html +renderRecipe recipe = do + H.nav $ H.ul $ H.li $ H.a ! A.href "/" $ "← Back to index" + H.h1 $ H.toHtml (titleText recipe) + renderMetadata (recipeMetadata recipe) + let allIngredients = collectIngredients recipe + unless (null allIngredients) $ do + H.h2 "Ingredients" + H.ul $ mapM_ renderIngredientItem allIngredients + H.hr + NE.toList (recipeSections recipe) & mapM_ renderSection + +-- | Extract display title from recipe metadata or fallback. +titleText :: Recipe -> Text +titleText recipe = + case metaTitle (recipeMetadata recipe) of + Just t -> t + Nothing -> "Untitled Recipe" + +-- --------------------------------------------------------------------------- +-- Metadata +-- --------------------------------------------------------------------------- + +-- | Render recipe metadata as a description list. +renderMetadata :: Metadata -> Html +renderMetadata meta = do + let rows = + catMaybes + [ pairWith (T.pack "Servings") (showServings <$> metaServings meta) + , pairWith (T.pack "Total time") (showDuration <$> metaTotalTime meta) + , pairWith (T.pack "Prep time") (showDuration <$> metaPrepTime meta) + , pairWith (T.pack "Cook time") (showDuration <$> metaCookTime meta) + , pairWith (T.pack "Difficulty") (metaDifficulty meta) + , pairWith (T.pack "Cuisine") (metaCuisine meta) + , pairWith (T.pack "Author") (metaAuthor meta) + , pairWith (T.pack "Source") (metaSource meta) + ] + unless (null rows) $ + H.dl $ + mapM_ (\(label, value) -> H.dt (H.toHtml label) >> H.dd (H.toHtml value)) rows + -- Tags as badges + let tags = metaTags meta + unless (null tags) $ + H.p $ do + "Tags: " + mapM_ (\t -> H.span ! A.class_ "tag" $ H.toHtml t) tags + +-- | Format servings info. +showServings :: (Int, Maybe Text) -> Text +showServings (n, Nothing) = T.pack (show n) +showServings (n, Just unit) = T.pack (show n) <> " " <> unit + +-- | Format a duration. +showDuration :: Duration -> Text +showDuration d = + let amt = durationAmount d + amount = case denominator amt of + 1 -> T.pack (show (numerator amt)) + _ -> T.pack (show (toDouble amt)) + unit = maybe "" Prelude.id (durationUnit d) + in T.strip (amount <> " " <> unit) + +-- | Roughly convert Rational to Double for display. +toDouble :: Rational -> Double +toDouble r = fromIntegral (numerator r) / fromIntegral (denominator r) + +-- --------------------------------------------------------------------------- +-- Sections +-- --------------------------------------------------------------------------- + +-- | Render one section of a recipe. +renderSection :: Section -> Html +renderSection section = do + case sectionName section of + Just name -> H.h3 $ H.toHtml name + Nothing -> pure () + NE.toList (sectionBody section) & mapM_ renderBodyItem + +-- | Render one body item (step, comment, or note). +renderBodyItem :: SectionBodyItem -> Html +renderBodyItem (SecStep step) = + H.p $ mapM_ renderStepItem (unStep step) +renderBodyItem (SecComment t) = + H.blockquote $ H.em $ H.toHtml ("-- " <> t) +renderBodyItem (SecNote t) = + H.blockquote $ H.small $ H.toHtml ("> " <> t) + +-- --------------------------------------------------------------------------- +-- Step items +-- --------------------------------------------------------------------------- + +-- | Render one inline element within a step. +renderStepItem :: StepItem -> Html +renderStepItem (StepText t) = H.toHtml t +renderStepItem (StepIngredient ing) = + H.mark ! A.class_ "roux-ingredient" $ do + H.toHtml (ingName ing) + case ingQuantity ing of + Nothing -> pure () + Just q -> do + " " + H.small $ "[" <> H.toHtml (showQuantity q) <> "]" +renderStepItem (StepCookware cw) = + H.span ! A.class_ "roux-cookware" $ + H.toHtml (cwName cw) +renderStepItem (StepTimer timer) = + H.span ! A.class_ "roux-timer" $ do + case timerName timer of + Just n -> H.toHtml n >> " " + Nothing -> pure () + H.small $ "⏱ " <> H.toHtml (showDuration (timerDuration timer)) +renderStepItem (StepRecipeRef ref) = + H.a ! A.href (H.toValue ("/recipes/" <> urlEncode (refPath ref <> ".cook"))) $ + H.toHtml (refPath ref) +renderStepItem (StepEndComment t) = + H.span ! A.class_ "roux-comment" $ H.em $ H.toHtml (" -- " <> t) +renderStepItem (StepComment t) = + H.span ! A.class_ "roux-comment" $ H.em $ H.toHtml ("[- " <> t <> " -]") +renderStepItem StepBreak = + H.br ! A.class_ "roux-break" + +-- | Render one ingredient in the ingredients summary list. +renderIngredientItem :: (Text, Maybe Quantity) -> Html +renderIngredientItem (name, qty) = + H.li $ do + H.toHtml name + case qty of + Nothing -> pure () + Just q -> do + " — " + H.small $ H.toHtml (showQuantity q) + +-- --------------------------------------------------------------------------- +-- Ingredients collection +-- --------------------------------------------------------------------------- + +{- | Collect all unique ingredients from a recipe with their first-seen +quantity. +-} +collectIngredients :: Recipe -> [(Text, Maybe Quantity)] +collectIngredients recipe = + let items = + recipe + & recipeSections + & NE.toList + >>= NE.toList . sectionBody + >>= bodyItemSteps + >>= unStep + ings = [i | StepIngredient i <- items] + in dedupFirst ings [] + +-- | Deduplicate ingredients by name, keeping first occurrence. +dedupFirst :: [Ingredient] -> [(Text, Maybe Quantity)] -> [(Text, Maybe Quantity)] +dedupFirst [] acc = reverse acc +dedupFirst (i : rest) acc = + if any ((== ingName i) . fst) acc + then dedupFirst rest acc + else dedupFirst rest ((ingName i, ingQuantity i) : acc) + +-- | Extract step items from a body item (returns empty for comments/notes). +bodyItemSteps :: SectionBodyItem -> [Step] +bodyItemSteps (SecStep s) = [s] +bodyItemSteps _ = [] + +-- --------------------------------------------------------------------------- +-- URL encoding +-- --------------------------------------------------------------------------- -- | Percent-encode a filename for use in a URL path segment. urlEncode :: FilePath -> Text @@ -53,3 +297,31 @@ urlEncode = T.pack . concatMap encodeChar | c == '#' = "%23" | c == '%' = "%25" | otherwise = [c] + +-- | Percent-decode a URL path segment back to a filename. +urlDecode :: Text -> FilePath +urlDecode t = concat (go [] (T.group t)) + where + go acc [] = reverse acc + go acc (s : rest) + | s == "%20" = go (" " : acc) rest + | s == "%23" = go ("#" : acc) rest + | s == "%25" = go ("%" : acc) rest + | otherwise = go (T.unpack s : acc) rest + +-- --------------------------------------------------------------------------- +-- Misc helpers +-- --------------------------------------------------------------------------- + +-- | Extract base filename without directory components. +takeBaseName :: FilePath -> String +takeBaseName = reverse . takeWhile (/= '/') . reverse + +-- | Check if an 'Either' is 'Left'. +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +-- | Check if an 'Either' is 'Right'. +isRight :: Either a b -> Bool +isRight = not . isLeft diff --git a/src/Roux/Parser.hs b/src/Roux/Parser.hs index 6389c9e..493760d 100644 --- a/src/Roux/Parser.hs +++ b/src/Roux/Parser.hs @@ -128,6 +128,10 @@ pLineBreak = do _ <- P.newline return StepBreak +-- | Characters allowed in recipe reference paths. +pPathChar :: Parser Char +pPathChar = P.alphaNum P.<|> P.oneOf "./-_" + -- | Recipe reference: @./path/to/recipe{quantity} pRecipeRef :: Parser StepItem pRecipeRef = do @@ -135,7 +139,7 @@ pRecipeRef = do -- Consume @ and store ./ as part of the path _ <- P.char '.' _ <- P.char '/' - path <- P.many (P.noneOf "{(\n\\") + path <- P.many pPathChar mqty <- P.optionMaybe (P.between (P.char '{') (P.char '}') pQuantityBody) return (StepRecipeRef (RecipeRef ("./" <> path) (join mqty))) @@ -147,6 +151,14 @@ pIngredient = do prep <- P.optionMaybe (P.try pPreparation) return (StepIngredient (Ingredient (T.pack name) qty (fmap T.strip prep))) +-- | Characters allowed in names that may include spaces (before braces). +pMultiNameChar :: Parser Char +pMultiNameChar = P.alphaNum P.<|> P.oneOf " .-'" + +-- | Characters allowed in single-word names (no braces). +pSingleNameChar :: Parser Char +pSingleNameChar = P.alphaNum P.<|> P.oneOf ".-'" + {- | Parse a name optionally followed by @{quantity}@ braces. Used by ingredients. First tries a multi-word name with braces @@ -156,14 +168,14 @@ pNameWithQuantity :: Parser ([Char], Maybe Quantity) pNameWithQuantity = P.try ( do - name <- P.many (P.noneOf "{(\n\\") + name <- P.many pMultiNameChar _ <- P.char '{' qty <- pQuantityBody _ <- P.char '}' return (name, qty) ) P.<|> do - name <- P.many1 (P.alphaNum P.<|> P.oneOf ".-'") + name <- P.many1 pSingleNameChar return (name, Nothing) {- | Parse a name optionally followed by empty @{}@ braces. @@ -174,12 +186,12 @@ pNameWithBraces :: Parser [Char] pNameWithBraces = P.try ( do - name <- P.many (P.noneOf "{(\n\\") + name <- P.many pMultiNameChar _ <- P.char '{' _ <- P.char '}' return name ) - P.<|> P.many1 (P.alphaNum P.<|> P.oneOf ".-'") + P.<|> P.many1 pSingleNameChar -- | Parse preparation text inside parentheses: @name(diced) pPreparation :: Parser Text diff --git a/src/Roux/Server.hs b/src/Roux/Server.hs index be97d70..812f5bb 100644 --- a/src/Roux/Server.hs +++ b/src/Roux/Server.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + {- | WAI application for the Roux recipe server. -Handles HTTP requests directly via wai — no framework. Currently serves -a single index page listing all discovered recipes. +Handles HTTP requests directly via wai — no framework. -} module Roux.Server ( app, @@ -9,6 +10,9 @@ module Roux.Server ( import Control.Monad (when) import Data.ByteString.Lazy (ByteString) +import Data.Char (toLower) +import Data.List (find) +import Data.Text (Text) import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai @@ -31,7 +35,6 @@ app recipeDir = do when (errs > 0) $ putStrLn $ "[roux] " <> show errs <> " had parse errors" - -- Return the application; recipes are captured in the closure. pure (handleRequest recipes) -- | Route an incoming request to the appropriate handler. @@ -39,8 +42,30 @@ handleRequest :: [Idx.RecipeInfo] -> Wai.Application handleRequest recipes request respond = case Wai.pathInfo request of [] -> respond (htmlResponse (Html.indexPage recipes)) + ["recipes", rawPath] -> + case lookupRecipe (urlDecodePath rawPath) recipes of + Just info -> respond (htmlResponse (Html.recipePage info)) + Nothing -> respond notFound _ -> respond notFound +-- | Look up a recipe by filename (case-insensitive, .cook extension optional). +lookupRecipe :: FilePath -> [Idx.RecipeInfo] -> Maybe Idx.RecipeInfo +lookupRecipe target recipes = + let normalised = map toLower (stripCookExt target) + in find (\(Idx.RecipeInfo fp _ _) -> map toLower (stripCookExt fp) == normalised) recipes + +-- | Strip the .cook extension if present. +stripCookExt :: FilePath -> FilePath +stripCookExt fp + | ".cook" `isSuffixOf` fp = take (length fp - 5) fp + | otherwise = fp + where + isSuffixOf suffix s = suffix == drop (length s - length suffix) s + +-- | Decode a percent-encoded URL path segment to a FilePath. +urlDecodePath :: Text -> FilePath +urlDecodePath = Html.urlDecode + -- | Build a 200 HTML response. htmlResponse :: ByteString -> Wai.Response htmlResponse body =