jbrechtel/roux
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Recipe detail page with server-side HTML rendering

Browse Source 
- 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
This commit is contained in:
James Brechtel
2026-05-19 07:12:14 -04:00
parent 4943d4d42e
commit b775fd4f3f
3 changed files with 339 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Roux/Html.hs
+294 -22
View File
@@ -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
src/Roux/Parser.hs
+17 -5
View File
@@ -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
src/Roux/Server.hs
+28 -3
View File
@@ -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 =