{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | WAI application for the Roux recipe server. Handles HTTP requests directly via wai — no framework. Recipes are loaded from disk at startup, then watched live via fsnotify. -} module Roux.Server ( app, ) where import Control.Concurrent (forkIO, threadDelay) import Control.Exception (IOException, SomeException, catch, finally, try) import Control.Monad (forM_, forever, when) import Data.ByteString.Base64 (decode) import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Char (digitToInt, isAlphaNum, toLower) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.List (isSuffixOf, sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Ord (Down (Down)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getModificationTime, makeAbsolute, removeFile) import System.FSNotify ( Event (..), EventIsDirectory (..), WatchConfig (..), WatchMode (..), defaultConfig, watchDir, withManagerConf, ) import System.FilePath (makeRelative, takeBaseName, takeExtension, ()) import qualified Data.Aeson as A import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString as BS import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Text.Encoding as TE import Data.Time.Calendar (Day, fromGregorianValid) import Data.Time.Clock (diffUTCTime, getCurrentTime, utctDay) import qualified Data.Time.Format as Time import qualified Database.SQLite.Simple as SQL import Roux.Config (AnthropicConfig (..), RouxConfig (..)) import qualified Roux.CookLog as CookLog import qualified Roux.CooklangPrint as CooklangPrint import qualified Roux.Html as Html import qualified Roux.RecipeIndex as Idx import Roux.SchemaOrg (SchemaOrgRecipe (..), parseSchemaOrgRecipe, schemaOrgToCooklang) import System.Exit (ExitCode (..)) import System.IO (hSetBinaryMode) import System.Process (CreateProcess (..), StdStream (CreatePipe), createProcess, proc, waitForProcess) import Text.Read (readMaybe) -- | Read the full request body as a lazy ByteString. readRequestBody :: Wai.Request -> IO LB.ByteString readRequestBody req = do chunks <- gather [] pure (LB.fromChunks chunks) where gather acc = do chunk <- Wai.getRequestBodyChunk req if BS.null chunk then pure (reverse acc) else gather (chunk : acc) {- | Build the WAI 'Application' given the recipe directory, a writable data directory, and config. Recipes are scanned at startup and then watched live via fsnotify. The cook log database is created (if absent) in @dataDir@, which must be writable — the recipe directory may be mounted read-only (as it is in the Docker deployment). -} app :: FilePath -> FilePath -> RouxConfig -> IO Wai.Application app recipeDir dataDir config = do putStrLn $ "[roux] scanning recipes from " <> recipeDir recipes <- Idx.scanRecipes recipeDir let count = length recipes ok = length [() | r <- recipes, isRight (Idx.riRecipe r)] errs = count - ok putStrLn $ "[roux] found " <> show count <> " recipe(s)" when (errs > 0) $ putStrLn $ "[roux] " <> show errs <> " had parse errors" -- Build initial map keyed by lowercased filename (without .cook extension) let recipeMap = Map.fromList [(map toLower (stripCookExt (Idx.riFilename r)), r) | r <- recipes] state <- newIORef recipeMap -- Resolve to absolute path so makeRelative works with fsnotify events absDir <- makeAbsolute recipeDir -- Change log for SSE notifications changeLog <- newIORef (0, []) -- Start the filesystem watcher _ <- forkIO $ watchRecipes absDir state changeLog `catch` \e -> putStrLn $ "[roux] watcher thread crashed: " <> show (e :: SomeException) -- Initialize cook log database in the writable data directory (initDb -- creates the directory and file if they are not already present). let dbPath = dataDir "cook-log.db" db <- CookLog.initDb dbPath putStrLn $ "[roux] cook log DB: " <> dbPath pure (router absDir config state changeLog db) where isRight (Right _) = True isRight (Left _) = False {- | A change log with a monotonic version counter and the last N changed filenames (newest first). -} type ChangeLog = IORef (Int, [(Int, FilePath)]) -- | Record a recipe file change in the change log. recordChange :: ChangeLog -> FilePath -> IO () recordChange changeLog path = atomicModifyIORef' changeLog $ \(version, entries) -> let newVersion = version + 1 newEntries = (newVersion, path) : take 99 entries in ((newVersion, newEntries), ()) {- | SSE endpoint — streams recipe-change events to connected clients. Polls 'ChangeLog' every 500ms and pushes any new events since the client's last seen version. Sends a @ping@ event every 30s as a keepalive. Client disconnect is detected by Warp when the write action throws. -} sseHandler :: ChangeLog -> Wai.Application sseHandler changeLog _request respond = do respond $ Wai.responseStream HTTP.status200 [ ("Content-Type", "text/event-stream") , ("Cache-Control", "no-cache") , ("Connection", "keep-alive") ] $ \write flush -> do lastSent <- newIORef 0 lastPing <- newIORef =<< getCurrentTime let sendPing = do write "event: ping\ndata: keepalive\n\n" flush let go = do now <- getCurrentTime (version, entries) <- readIORef changeLog sent <- readIORef lastSent when (version > sent) $ do let newEntries = takeWhile (\(v, _) -> v > sent) entries -- Entries are newest-first. Deduplicate by filename, -- keeping the newest (first encountered) entry per file. let deduped = foldl' ( \acc e@(_, p) -> if any ((== p) . snd) acc then acc else e : acc ) [] newEntries forM_ deduped $ \(_v, path) -> do write ( lazyByteString $ LB.fromStrict $ encodeUtf8 $ T.unlines [ "event: recipe-changed" , "data: " <> T.pack path , "" , "" ] ) writeIORef lastSent version flush pingTime <- readIORef lastPing when (diffUTCTime now pingTime > 30) $ do writeIORef lastPing now sendPing threadDelay 500_000 -- 500ms poll interval go -- Send an initial ping so the client detects connection immediately pingTime <- getCurrentTime writeIORef lastPing pingTime sendPing go `finally` pure () -- | Route requests — SSE endpoint, recipe pages, or import. router :: FilePath -> RouxConfig -> IORef (Map FilePath Idx.RecipeInfo) -> ChangeLog -> SQL.Connection -> Wai.Application router recipeDir config state changeLog db request respond = case Wai.pathInfo request of ["events"] -> sseHandler changeLog request respond ["import"] -> importHandler recipeDir config state request respond ["upload-image"] -> uploadImageHandler recipeDir state request respond ["recipe-images", filename] -> serveRecipeImage recipeDir (T.unpack filename) request respond ["recipes", _, "title"] | Wai.requestMethod request == "PATCH" -> titleUpdateHandler recipeDir state request respond pathInfo | Just filename <- dispatchLogPost pathInfo , Wai.requestMethod request == "POST" -> handleCookLogPost db filename request respond _ -> handleRequest recipeDir state db request respond -- | Extract filename from /cook-log/{filename} POST path, if it matches. dispatchLogPost :: [Text] -> Maybe Text dispatchLogPost ["cook-log", filename] = Just filename dispatchLogPost _ = Nothing {- | Handle GET and POST requests to /import. GET — show the import form. POST — dispatch based on input: URL (existing scraper), text, or file (Anthropic). Files are uploaded as base64-encoded content via hidden form fields (file-b64, file-name, file-mime) set by client-side JavaScript. -} importHandler :: FilePath -> RouxConfig -> IORef (Map FilePath Idx.RecipeInfo) -> Wai.Application importHandler recipeDir config _state request respond = case Wai.requestMethod request of "GET" -> respond (htmlResponse (Html.importPage Nothing)) "POST" -> do body <- readRequestBody request let params = parseFormBody body url = fromMaybe "" (lookup "url" params) text = fromMaybe "" (lookup "text" params) fileB64 = fromMaybe "" (lookup "file-b64" params) fileName = fromMaybe "" (lookup "file-name" params) fileMime = fromMaybe "" (lookup "file-mime" params) hasFile = not (T.null fileB64) putStrLn $ "[roux] import request: url=" <> T.unpack url <> " text=" <> show (not (T.null text)) <> " file=" <> show hasFile result <- try $ case (hasFile, not (T.null text), not (T.null url)) of -- File takes priority, then text, then URL (True, _, _) -> runFileImport recipeDir config fileName fileMime fileB64 (_, True, _) -> runTextImport recipeDir config text (_, _, True) -> runImportPipeline recipeDir url _ -> pure (Left (Html.ImportError "Provide a URL, recipe text, or file to import.")) case result of Left (e :: SomeException) -> respond $ htmlResponse $ Html.importResultPage $ Html.ImportError ("Unexpected error: " <> T.pack (show e)) Right (Left err) -> respond $ htmlResponse $ Html.importResultPage err Right (Right filename) -> respond $ Wai.responseLBS HTTP.status303 [("Location", "/recipes/" <> TE.encodeUtf8 (T.pack filename))] "" _ -> respond notFound -- | Parse URL-encoded form body into key-value pairs. parseFormBody :: LB.ByteString -> [(Text, Text)] parseFormBody body = let decoded = TE.decodeUtf8 $ LB.toStrict body parts = T.splitOn "&" decoded in mapMaybe parsePair parts where parsePair part = case T.splitOn "=" part of [key, val] -> Just (urldecode key, urldecode val) _ -> Nothing -- Proper percent-decode for all %XX sequences (not just %20/%23/%25). urldecode = T.pack . go . T.unpack . T.replace "+" " " go [] = [] go ('%' : a : b : rest) = let hexVal = digitToInt a * 16 + digitToInt b in toEnum hexVal : go rest go (c : rest) = c : go rest {- | Run a subprocess and capture stdout/stderr as raw bytes (no locale decoding). Reads output eagerly to avoid the classic lazy-IO deadlock where the parent blocks on waitForProcess while the child blocks on a full pipe buffer. -} readProcessBytes :: FilePath -> [String] -> IO (ExitCode, LB.ByteString, LB.ByteString) readProcessBytes cmd args = do let process = (proc cmd args) { std_out = CreatePipe , std_err = CreatePipe } result <- createProcess process case result of (Nothing, Just outH, Just errH, ph) -> do hSetBinaryMode outH True hSetBinaryMode errH True -- Read stdout and stderr strictly before waiting for the process. -- Using length forces the lazy ByteString, triggering eager reads -- and preventing the pipe buffer from filling up. -- hSetBuffering would also work but requires knowing a buffer size. out <- LB.hGetContents outH err <- LB.hGetContents errH -- Force full evaluation before waitForProcess to avoid deadlock. let outLen = LB.length out errLen = LB.length err outLen `seq` errLen `seq` do ec <- waitForProcess ph pure (ec, out, err) _ -> ioError $ userError $ "[roux] createProcess did not return std_out/std_err pipes for " <> cmd -- | Locate the scrape-recipe script: check PATH first, then relative to project. findScrapeScript :: IO FilePath findScrapeScript = do -- In production Docker, the script is at /usr/local/bin/scrape-recipe (on PATH). -- In development from the project root, it is at scripts/scrape-recipe. mPath <- findExecutable "scrape-recipe" case mPath of Just p -> pure p Nothing -> pure "scripts/scrape-recipe" -- | Run the full import pipeline: scrape -> parse -> convert -> render -> save. runImportPipeline :: FilePath -> Text -> IO (Either Html.ImportError FilePath) runImportPipeline recipeDir url = do -- Step 1: locate and run the scraper script <- findScrapeScript putStrLn $ "[roux] importing from " <> T.unpack url <> " using script " <> script (exitCode, stdoutBytes, stderrBytes) <- readProcessBytes script ["--pretty", T.unpack url] case exitCode of ExitFailure _ -> do putStrLn $ "[roux] scrape-recipe exited with code " <> show exitCode <> " for " <> T.unpack url putStrLn $ "[roux] scrape-recipe stderr: " <> T.unpack (TE.decodeUtf8 (LB.toStrict stderrBytes)) return $ Left $ Html.ImportError $ "Could not scrape URL (" <> url <> "). The scraper exited with: " <> TE.decodeUtf8 (LB.toStrict stderrBytes) ExitSuccess -> do -- Step 2: decode stdout (raw bytes) as JSON Value let jsonVal = A.decode stdoutBytes :: Maybe A.Value case jsonVal of Nothing -> do putStrLn $ "[roux] failed to decode JSON from scrape-recipe stdout for " <> T.unpack url return $ Left $ Html.ImportError $ "Could not parse JSON from scraper output (" <> url <> ")." Just val -> case parseSchemaOrgRecipe val of Nothing -> do putStrLn $ "[roux] no schema.org Recipe found in JSON for " <> T.unpack url return $ Left $ Html.ImportError $ "Could not parse recipe data from " <> url <> ". The page may not have schema.org recipe data." Just schema -> case schemaOrgToCooklang schema of Left err -> do putStrLn $ "[roux] failed to convert schema.org recipe for " <> T.unpack url <> ": " <> T.unpack (T.pack err) return $ Left $ Html.ImportError $ "Could not convert recipe from " <> url <> ": " <> T.pack err Right recipe -> do -- Step 3: render to Cooklang text let cookText = CooklangPrint.renderRecipe recipe filename = CooklangPrint.filenameFromTitle (soName schema) filepath = recipeDir filename -- Save raw JSON alongside the .cook for debugging jsonFilename = takeBaseName filename <> ".json" jsonFilepath = recipeDir jsonFilename -- Step 4: write raw JSON from scraper putStrLn $ "[roux] writing raw scraper JSON to " <> jsonFilepath LB.writeFile jsonFilepath stdoutBytes -- Step 5: write the .cook file putStrLn $ "[roux] writing imported recipe to " <> filepath BS.writeFile filepath (TE.encodeUtf8 cookText) putStrLn $ "[roux] successfully imported " <> T.unpack url <> " as " <> filename return $ Right filename {- | Import a recipe from an uploaded file via the LLM pipeline. The file content is base64-encoded in the form data. -} runFileImport :: -- | recipe directory FilePath -> -- | server config (for Anthropic settings) RouxConfig -> -- | original filename Text -> -- | MIME type Text -> -- | base64-encoded file content Text -> IO (Either Html.ImportError FilePath) runFileImport recipeDir config originalName _mimeType b64Text = do -- Decode base64 case decode (TE.encodeUtf8 b64Text) of Left err -> pure $ Left $ Html.ImportError $ "Could not decode uploaded file: " <> T.pack err Right content -> do -- Save the original file to recipe-images/ subdirectory let imagesDir = recipeDir "recipe-images" safeName = map (\c -> if isAlphaNum c || c == '.' || c == '-' || c == '_' then c else '_') (T.unpack originalName) sourcePath = imagesDir safeName sourceUrl = "/recipe-images/" <> T.pack safeName createDirectoryIfMissing True imagesDir BS.writeFile sourcePath content putStrLn $ "[roux] saved uploaded file to " <> sourcePath -- Call the LLM pipeline with the source URL case rcAnthropic config of Nothing -> pure $ Left $ Html.ImportError "LLM import is not configured. Add an anthropic.api_key to the config file." Just anthropicConfig -> do result <- runLLMPipeline recipeDir anthropicConfig (Just sourceUrl) (Just sourcePath) "" case result of Right filename -> pure $ Right filename Left err -> pure $ Left err -- | Import a recipe from pasted text via the LLM pipeline. runTextImport :: FilePath -> RouxConfig -> Text -> IO (Either Html.ImportError FilePath) runTextImport recipeDir config text = do case rcAnthropic config of Nothing -> pure $ Left $ Html.ImportError "LLM import is not configured. Add an anthropic.api_key to the config file." Just anthropicConfig -> runLLMPipeline recipeDir anthropicConfig Nothing Nothing text -- | Run the full LLM import pipeline: call convert-to-cooklang -> parse -> save. runLLMPipeline :: -- | recipe directory FilePath -> -- | API config AnthropicConfig -> -- | Just url = source URL to inject into Cooklang front matter Maybe Text -> -- | Just path = file path for the script (file upload) / Nothing = use text Maybe FilePath -> -- | recipe text (used when no file path) Text -> IO (Either Html.ImportError FilePath) runLLMPipeline recipeDir anthropicConfig mSourceUrl mFilePath text = do -- Step 1: locate the script script <- findConvertScript -- Step 2: write a temp config for the subprocess let configPath = recipeDir ".convert-config.yaml" writeConvertConfig configPath anthropicConfig -- Step 3: build subprocess args let args = case mFilePath of Just fp -> ["--config", configPath, "--file", fp] Nothing -> ["--config", configPath, "--text", T.unpack text] putStrLn $ "[roux] running " <> script <> " for LLM import" (exitCode, stdoutBytes, stderrBytes) <- readProcessBytes script args -- Clean up temp config _ <- try (removeFile configPath) :: IO (Either IOException ()) case exitCode of ExitFailure _ -> do let errMsg = TE.decodeUtf8 (LB.toStrict stderrBytes) putStrLn $ "[roux] convert-to-cooklang failed: " <> T.unpack errMsg return $ Left $ Html.ImportError $ "Could not convert recipe: " <> errMsg ExitSuccess -> do -- Step 4: parse the Cooklang output to extract the title let rawCooklang = TE.decodeUtf8 (LB.toStrict stdoutBytes) cooklangText = case mSourceUrl of Just url -> injectSourceUrl rawCooklang url Nothing -> rawCooklang case parseRecipeTitle cooklangText of Nothing -> do putStrLn "[roux] could not extract title from Cooklang output" return $ Left $ Html.ImportError "Could not determine recipe title from AI output." Just title -> do let filename = CooklangPrint.filenameFromTitle title filepath = recipeDir filename -- Step 5: write the .cook file putStrLn $ "[roux] writing imported recipe to " <> filepath BS.writeFile filepath (TE.encodeUtf8 cooklangText) putStrLn $ "[roux] successfully imported recipe as " <> filename return $ Right filename -- | Locate the convert-to-cooklang script. findConvertScript :: IO FilePath findConvertScript = do mPath <- findExecutable "convert-to-cooklang" case mPath of Just p -> pure p Nothing -> ioError $ userError $ "convert-to-cooklang not found on PATH. " <> "Install it to /usr/local/bin/convert-to-cooklang or add it to PATH." -- | Write a temporary YAML config for the subprocess. writeConvertConfig :: FilePath -> AnthropicConfig -> IO () writeConvertConfig path ac = do let pairs = [ "anthropic:" , " api_key: " <> T.unpack (acApiKey ac) ] ++ case acBaseUrl ac of Just url -> [" base_url: " <> T.unpack url] Nothing -> [] ++ case acModel ac of Just m -> [" model: " <> T.unpack m] Nothing -> [] writeFile path (unlines pairs) {- | Insert or update the 'source:' field in Cooklang YAML front matter. If a source field already exists, its value is replaced. Otherwise a new source line is added before the closing '---'. -} injectSourceUrl :: Text -> Text -> Text injectSourceUrl cooklang url = case T.breakOn "---" cooklang of (before, rest) -> let afterFirst = T.drop 3 rest (frontMatter, afterSecond) = T.breakOn "---" afterFirst updated = let (beforeSource, afterSource) = T.breakOn "source:" frontMatter in if T.null afterSource -- No existing source field: append one then let trimmed = T.stripEnd frontMatter in trimmed <> "\nsource: " <> url <> "\n" -- Existing source field: replace its value else let restOfLine = T.drop 1 (T.dropWhile (/= '\n') afterSource) in beforeSource <> "source: " <> url <> restOfLine in before <> "---" <> updated <> "---" <> afterSecond {- | Parse the recipe title from Cooklang front matter. Looks for "title: ..." in the YAML front matter block. -} parseRecipeTitle :: Text -> Maybe Text parseRecipeTitle cooklang = case T.breakOn "---" cooklang of (_, afterFirst) -> let (_separator, inside) = T.breakOn "---" (T.drop 3 afterFirst) frontMatter = T.take (T.length inside) (T.drop 3 afterFirst) in case T.breakOn "title:" frontMatter of (_, afterTitle) -> let titleLine = T.takeWhile (/= '\n') (T.drop 6 afterTitle) cleaned = T.strip titleLine in if T.null cleaned then Nothing else Just cleaned {- | Watch a directory for .cook file changes and update the shared state. Uses watchDir callback for simplicity. -} watchRecipes :: FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> ChangeLog -> IO () watchRecipes dir state changeLog = do putStrLn $ "[roux] watching " <> dir <> " for changes" let cfg = defaultConfig{confWatchMode = WatchModeOS} withManagerConf cfg $ \mgr -> do _stopListening <- watchDir mgr dir (const True) $ \ev -> catch ( do when (eventIsDirectory ev == IsFile && ".cook" `isSuffixOf` eventPath ev) $ do let path = makeRelative dir (eventPath ev) reReadRecipe dir path state changeLog ) ( \e -> putStrLn $ "[roux] watchDir callback error: " <> show (e :: SomeException) ) -- Keep the thread alive (watchDir runs the callback on the manager thread) forever $ threadDelay 1_000_000 {- | Re-read a single recipe file and update the shared state. On read/parse errors, logs the error and keeps the previous version. -} reReadRecipe :: FilePath -> FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> ChangeLog -> IO () reReadRecipe dir path state changeLog = do let key = map toLower (stripCookExt path) let fullPath = dir path result <- try (doesFileExist fullPath) case result of Left (_ :: IOException) -> do putStrLn $ "[roux] IO error checking " <> path <> ", skipping" Right False -> do atomicModifyIORef' state $ \m -> (Map.delete key m, ()) recordChange changeLog path putStrLn $ "[roux] removed " <> path Right True -> do content <- try (Idx.loadRecipe dir path) case content of Left (_ :: IOException) -> do putStrLn $ "[roux] IO error reading " <> path <> ", keeping previous version" Right info -> case Idx.riRecipe info of Left err -> do putStrLn $ "[roux] parse error in " <> path <> ": " <> err putStrLn "[roux] keeping previous version" Right _ -> do atomicModifyIORef' state $ \m -> (Map.insert key info m, ()) recordChange changeLog path putStrLn $ "[roux] updated " <> path -- | Route an incoming request to the appropriate handler. handleRequest :: FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> SQL.Connection -> Wai.Application handleRequest recipeDir state db request respond = do recipes <- readIORef state let recipeList = Map.elems recipes case Wai.pathInfo request of -- Landing page (root) [] -> do allEntries <- CookLog.fetchAllEntries db let okRecipes = filter (\r -> case Idx.riRecipe r of Right _ -> True; _ -> False) recipeList -- Deduplicate cook entries by recipe filename, keep most recent let deduped = deduplicateByRecipe allEntries -- Look up recipe info for each recently cooked entry lookupInfo e = case Map.lookup (map toLower (stripCookExt (T.unpack (CookLog.ceRecipeFilename e)))) recipes of Just info -> Just (e, info) Nothing -> Nothing cookedWithInfo = mapMaybe lookupInfo (take 10 deduped) -- Get recently added recipes (by modification time) recentlyAdded <- getRecentlyAdded recipeDir okRecipes respond $ htmlResponse (Html.landingPage okRecipes cookedWithInfo recentlyAdded) -- Recipe index page ["recipes"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList)) ["recipes", "sorted", "tags"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList)) ["recipes", "sorted", "course"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList)) -- Recipe detail page ["recipes", rawPath] -> case lookupRecipe (urlDecodePath rawPath) recipes of Just info -> do let filename = T.pack (map toLower (stripCookExt (urlDecodePath rawPath))) entries <- CookLog.fetchEntries db filename respond (htmlResponse (Html.recipePage info entries)) Nothing -> respond notFound -- Cook log JSON endpoint for a specific recipe ["cook-log", filename] -> do entries <- CookLog.fetchEntries db (normalizeRecipeKey filename) let body = A.encode entries respond $ Wai.responseLBS HTTP.status200 [("Content-Type", "application/json")] body -- Cook history page (all entries across recipes) ["cook-history"] -> do entries <- CookLog.fetchAllEntries db let grouped = groupEntries entries recipeTitleLookup fn = maybe fn Idx.riTitle (Map.lookup (map toLower (stripCookExt (T.unpack fn))) recipes) respond $ htmlResponse (Html.cookHistoryPage recipeTitleLookup grouped) -- Cook log JSON endpoint for all entries ["cook-log"] -> do entries <- CookLog.fetchAllEntries db respond $ Wai.responseLBS HTTP.status200 [("Content-Type", "application/json")] (A.encode entries) _ -> respond notFound -- | Deduplicate cook entries by recipe filename, keeping the most recent entry per recipe. deduplicateByRecipe :: [CookLog.CookEntry] -> [CookLog.CookEntry] deduplicateByRecipe entries = let seen = foldl' addIfNew [] entries in reverse seen where addIfNew acc e = if any ((== CookLog.ceRecipeFilename e) . CookLog.ceRecipeFilename) acc then acc else e : acc -- | Get recently added recipes sorted by modification time (newest first). getRecentlyAdded :: FilePath -> [Idx.RecipeInfo] -> IO [Idx.RecipeInfo] getRecentlyAdded recipeDir recipes = do times <- mapM ( \r -> do let filepath = recipeDir Idx.riFilename r result <- try (getModificationTime filepath) case result of Left (_ :: IOException) -> pure Nothing Right t -> pure (Just (r, t)) ) recipes let valid = catMaybes times sorted = sortOn (Down . snd) valid pure (Prelude.map fst (take 10 sorted)) {- | Handle POST /cook-log/{filename} | Normalize a recipe filename to match the recipe index key: lowercased, with @.cook@ extension stripped. -} normalizeRecipeKey :: Text -> Text normalizeRecipeKey = T.pack . map toLower . stripCookExt . T.unpack handleCookLogPost :: SQL.Connection -> Text -> Wai.Application handleCookLogPost db rawFilename request respond = do let filename = normalizeRecipeKey rawFilename body <- readRequestBody request let params = parseFormBody body dateStr = fromMaybe "" (lookup "cooked-date" params) comment = lookup "comment" params let doInsert d = do _ <- CookLog.insertEntry db filename d comment respond $ Wai.responseLBS HTTP.status200 [("Content-Type", "application/json")] (LB.fromStrict (encodeUtf8 "{\"ok\":true}")) case parseDate dateStr of Just d -> doInsert d Nothing -> if T.null dateStr then getCurrentDay >>= doInsert else let resp = Wai.responseLBS HTTP.status400 [("Content-Type", "application/json")] (LB.fromStrict (encodeUtf8 "{\"error\":\"Invalid date format\"}")) in respond resp -- | Get today's date. getCurrentDay :: IO Day getCurrentDay = utctDay <$> getCurrentTime -- | Parse a YYYY-MM-DD date string. parseDate :: Text -> Maybe Day parseDate t = case T.splitOn "-" t of [y, m, d] -> do y' <- readMaybe (T.unpack y) m' <- readMaybe (T.unpack m) d' <- readMaybe (T.unpack d) fromGregorianValid y' m' d' _ -> Nothing -- | Group entries by month label (e.g. "March 2026"), sorted newest-first. groupEntries :: [CookLog.CookEntry] -> [(Text, [CookLog.CookEntry])] groupEntries [] = [] groupEntries entries = let monthKey d = T.pack $ Time.formatTime Time.defaultTimeLocale "%B %Y" d groups = Map.fromListWith (++) [(monthKey (CookLog.ceCookedDate e), [e]) | e <- entries] -- Sort month groups by the newest entry date in each group, descending. -- Every group is non-empty by construction. monthDate = foldl max (toEnum 0) . map CookLog.ceCookedDate sortedMonths = map fst $ sortOn (Down . monthDate . snd) $ Map.toList groups in [(m, Map.findWithDefault [] m groups) | m <- sortedMonths] -- | Look up a recipe by filename (case-insensitive, .cook extension optional). lookupRecipe :: FilePath -> Map FilePath Idx.RecipeInfo -> Maybe Idx.RecipeInfo lookupRecipe target = Map.lookup (map toLower (stripCookExt target)) -- | Strip the .cook extension if present. stripCookExt :: FilePath -> FilePath stripCookExt fp | ".cook" `isSuffixOf` fp = take (length fp - 5) fp | otherwise = fp -- | 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 = Wai.responseLBS HTTP.status200 [("Content-Type", "text/html; charset=utf-8")] -- | 404 response. notFound :: Wai.Response notFound = Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not found" -- --------------------------------------------------------------------------- -- Image upload and serving -- --------------------------------------------------------------------------- {- | Handle image upload requests (POST only). Expects form fields: filename (recipe .cook name), file-b64 (base64 content), file-name (original filename for extension detection). -} uploadImageHandler :: FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> Wai.Application uploadImageHandler recipeDir _state request respond = case Wai.requestMethod request of "POST" -> do body <- readRequestBody request let params = parseFormBody body filename = fromMaybe "" (lookup "filename" params) fileB64 = fromMaybe "" (lookup "file-b64" params) originalName = fromMaybe "" (lookup "file-name" params) if T.null filename then respond (jsonError "Missing 'filename' parameter") else if T.null fileB64 then respond (jsonError "Missing 'file-b64' parameter") else do let basename = T.pack (stripCookExt (T.unpack filename)) ext = takeExtension (T.unpack originalName) safeName = map (\c -> if isAlphaNum c || c == '.' || c == '-' || c == '_' then c else '_') (T.unpack basename <> if null ext then ".jpg" else ext) imageFilename = T.pack safeName imagesDir = recipeDir "recipe-images" filepath = imagesDir safeName case decode (TE.encodeUtf8 fileB64) of Left err -> respond (jsonError ("Base64 decode failed: " <> T.pack err)) Right content -> do -- Ensure the recipe-images directory exists createDirectoryIfMissing True imagesDir -- Save the image file BS.writeFile filepath content putStrLn $ "[roux] saved recipe image to " <> filepath -- Update the .cook file with image metadata let cookPath = recipeDir T.unpack filename imageUrl = "/recipe-images/" <> imageFilename exists <- doesFileExist cookPath if not exists then respond (jsonError "Recipe file not found") else do updateImageMetadata cookPath imageUrl putStrLn $ "[roux] updated image metadata for " <> T.unpack filename respond (jsonOk [("image", imageUrl)]) _ -> respond notFound -- | Serve a static recipe image file from the recipe directory. serveRecipeImage :: FilePath -> FilePath -> Wai.Application serveRecipeImage recipeDir filename _request respond = do -- Security: only allow known image extensions let ext = map toLower (takeExtension filename) if ext `notElem` [".jpg", ".jpeg", ".png", ".gif", ".webp"] then respond notFound else do let filepath = recipeDir "recipe-images" filename exists <- doesFileExist filepath if not exists then respond notFound else do content <- BS.readFile filepath let contentType = case ext of ".jpg" -> "image/jpeg" ".jpeg" -> "image/jpeg" ".png" -> "image/png" ".gif" -> "image/gif" ".webp" -> "image/webp" _ -> "application/octet-stream" respond $ Wai.responseLBS HTTP.status200 [("Content-Type", contentType)] (LB.fromStrict content) {- | Update the @image:@ key in a recipe's YAML front matter. If no front matter exists, one is created. -} updateImageMetadata :: FilePath -> Text -> IO () updateImageMetadata cookFilePath imageUrl = do content <- BS.readFile cookFilePath let text = TE.decodeUtf8 content updated = case T.stripPrefix "---\n" text of Just afterOpen -> let (yamlBlock, rest) = T.breakOn "\n---" afterOpen newYaml = addOrUpdateYamlKey "image" imageUrl yamlBlock in "---\n" <> newYaml <> rest Nothing -> "---\nimage: " <> imageUrl <> "\n---\n\n" <> text BS.writeFile cookFilePath (TE.encodeUtf8 updated) -- | Update the title in a .cook file's YAML front matter. updateTitleInCookFile :: FilePath -> Text -> IO () updateTitleInCookFile filepath newTitle = do content <- BS.readFile filepath let text = TE.decodeUtf8 content updated = case T.stripPrefix "---\n" text of Just afterOpen -> let (yamlBlock, rest) = T.breakOn "\n---" afterOpen newYaml = addOrUpdateYamlKey "title" newTitle yamlBlock in "---\n" <> newYaml <> rest Nothing -> "---\ntitle: " <> newTitle <> "\n---\n\n" <> text BS.writeFile filepath (TE.encodeUtf8 updated) -- | Add or update a key: value line in a YAML block, preserving other keys. addOrUpdateYamlKey :: Text -> Text -> Text -> Text addOrUpdateYamlKey key value yaml = let yamlLines = T.lines yaml keyPrefix = key <> ":" hasKey = any (\l -> keyPrefix `T.isPrefixOf` T.stripStart l) yamlLines in if hasKey then T.unlines (map (replaceKeyLine keyPrefix) yamlLines) else yaml <> "\n" <> key <> ": " <> value where replaceKeyLine prefix line | prefix `T.isPrefixOf` T.stripStart line = key <> ": " <> value | otherwise = line -- | Build a JSON OK response with a list of key-value pairs. jsonOk :: [(Text, Text)] -> Wai.Response jsonOk pairs = let inner = T.intercalate ", " (map (\(k, v) -> "\"" <> k <> "\":\"" <> v <> "\"") pairs) in Wai.responseLBS HTTP.status200 [("Content-Type", "application/json")] (LB.fromStrict (encodeUtf8 ("{" <> inner <> "}"))) -- | Build a JSON error response. jsonError :: Text -> Wai.Response jsonError msg = Wai.responseLBS HTTP.status400 [("Content-Type", "application/json")] (LB.fromStrict (encodeUtf8 ("{\"error\":\"" <> msg <> "\"}"))) -- | Handle PATCH /recipes/{filename}/title -- update the recipe title. titleUpdateHandler :: FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> Wai.Application titleUpdateHandler recipeDir state request respond = do recipes <- readIORef state case Wai.pathInfo request of ["recipes", rawPath, "title"] -> do let key = map toLower (stripCookExt (T.unpack rawPath)) case Map.lookup key recipes of Nothing -> respond (jsonError "Recipe not found") Just info -> do body <- readRequestBody request case A.decode body of Nothing -> respond (jsonError "Invalid JSON body") Just (val :: A.Value) -> case titleFromJson val of Nothing -> respond (jsonError "Missing 'title' field") Just title -> do let trimmed = T.strip title if T.null trimmed then respond (jsonError "Title cannot be empty") else do let filepath = recipeDir Idx.riFilename info result <- try $ updateTitleInCookFile filepath trimmed case result of Left (_ :: IOException) -> respond (jsonError "Could not update recipe file") Right () -> respond $ jsonOk [ ("success", "true") , ("title", trimmed) ] _ -> respond notFound where titleFromJson :: A.Value -> Maybe Text titleFromJson (A.Object obj) = case KM.lookup "title" obj of Just (A.String t) -> Just t _ -> Nothing titleFromJson _ = Nothing