jbrechtel
460b7d0fdc
Build and Deploy / build-and-deploy (push) Successful in 2m43s
The cook log SQLite DB was created at recipeDir/cook-log.db. In the Docker deployment /recipes is mounted read-only, so SQLite could never create the file there — the cook log has never worked in the container. The writable /data volume was mounted but unused. - initDb now creates the DB's parent directory if missing, so startup initialization is self-contained and idempotent. - app takes a dataDir and places cook-log.db there. - Add optional --data-dir flag (defaults to the recipe dir, preserving local-dev behavior); Docker CMD passes --data-dir /data. Verified end-to-end as root against a read-only recipe dir and a non-existent data dir: the dir and DB are created and cook-log POST/GET round-trips. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
987 lines
44 KiB
Haskell
987 lines
44 KiB
Haskell
{-# 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
|