feat: watch recipe directory for live updates via fsnotify

This commit is contained in:
2026-05-19 23:14:24 -04:00
parent a8402cf831
commit a2a8ea7b99
2 changed files with 96 additions and 19 deletions
+4 -2
View File
@@ -4,6 +4,7 @@
module Roux.RecipeIndex (
RecipeInfo (..),
RecipeSearchEntry (..),
loadRecipe,
scanRecipes,
toSearchEntry,
) where
@@ -81,8 +82,9 @@ toSearchEntry info =
, rseTags = tags
}
-- | Extract a display title from the recipe's metadata or fall back to the
-- filename.
{- | Extract a display title from the recipe's metadata or fall back to the
filename.
-}
extractTitle :: Recipe -> FilePath -> Text
extractTitle recipe filename =
case metaTitle (recipeMetadata recipe) of
+92 -17
View File
@@ -3,26 +3,42 @@
{- | 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)
import Control.Concurrent.Chan (Chan, newChan, readChan)
import Control.Monad (when)
import Data.ByteString.Lazy (ByteString)
import Data.Char (toLower)
import Data.List (find)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import System.Directory (doesFileExist)
import System.FSNotify (
Event (..),
EventIsDirectory (..),
WatchConfig (..),
WatchMode (..),
defaultConfig,
watchTreeChan,
withManagerConf,
)
import System.FilePath ((</>))
import qualified Roux.Html as Html
import qualified Roux.RecipeIndex as Idx
{- | Build the WAI 'Application' given a path to the recipe directory.
Recipes are scanned once at startup. A future improvement could watch
the directory for changes and rebuild the index.
Recipes are scanned at startup and then watched live via fsnotify.
-}
app :: FilePath -> IO Wai.Application
app recipeDir = do
@@ -35,18 +51,83 @@ app recipeDir = do
when (errs > 0) $
putStrLn $
"[roux] " <> show errs <> " had parse errors"
pure (handleRequest recipes)
-- Build initial map keyed by lowercased filename
let recipeMap = Map.fromList [(map toLower (Idx.riFilename r), r) | r <- recipes]
state <- newIORef recipeMap
-- Start the filesystem watcher
_ <- forkIO (watchRecipes recipeDir state)
pure (handleRequest state)
where
isRight (Right _) = True
isRight (Left _) = False
{- | Watch a directory for .cook file changes and update the shared state.
Implements debouncing: events for the same path within 200ms are skipped.
-}
watchRecipes :: FilePath -> IORef (Map FilePath Idx.RecipeInfo) -> IO ()
watchRecipes dir state = do
putStrLn $ "[roux] watching " <> dir <> " for changes"
let cfg = defaultConfig{confWatchMode = WatchModeOS}
withManagerConf cfg $ \mgr -> do
chan <- newChan
_stopListening <- watchTreeChan mgr dir (const True) chan
debounceLoop chan state dir Map.empty
where
debounceLoop :: Chan Event -> IORef (Map FilePath Idx.RecipeInfo) -> FilePath -> Map FilePath UTCTime -> IO ()
debounceLoop chan st dr lastSeen = do
ev <- readChan chan
let isDir = eventIsDirectory ev
now <- getCurrentTime
if isDir == IsDirectory
then debounceLoop chan st dr lastSeen
else do
let path = eventPath ev
let key = map toLower path
let lastTime = Map.lookup key lastSeen
case lastTime of
Just t | diffUTCTime now t < 0.2 -> do
debounceLoop chan st dr lastSeen
_ -> do
reReadRecipe dr path st
debounceLoop chan st dr (Map.insert key now lastSeen)
{- | 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) -> IO ()
reReadRecipe dir path state = do
let fullPath = dir </> path
exists <- doesFileExist fullPath
if not exists
then do
let key = map toLower path
atomicModifyIORef' state $ \m ->
(Map.delete key m, ())
putStrLn $ "[roux] removed " <> path
else do
info <- Idx.loadRecipe dir path
let key = map toLower path
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, ())
putStrLn $ "[roux] updated " <> path
-- | Route an incoming request to the appropriate handler.
handleRequest :: [Idx.RecipeInfo] -> Wai.Application
handleRequest recipes request respond =
handleRequest :: IORef (Map FilePath Idx.RecipeInfo) -> Wai.Application
handleRequest state request respond = do
recipes <- readIORef state
let recipeList = Map.elems recipes
case Wai.pathInfo request of
-- Index page (default: alphabetical)
[] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipes))
[] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList))
-- Index page (sorted by tags) — sort mode ignored, driven client-side
["sorted", "tags"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipes))
["sorted", "tags"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList))
-- Index page (sorted by course/category) — sort mode ignored, driven client-side
["sorted", "course"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipes))
["sorted", "course"] -> respond (htmlResponse (Html.indexPage Html.AlphaSort recipeList))
-- Recipe detail page
["recipes", rawPath] ->
case lookupRecipe (urlDecodePath rawPath) recipes of
@@ -55,10 +136,9 @@ handleRequest recipes request respond =
_ -> respond notFound
-- | Look up a recipe by filename (case-insensitive, .cook extension optional).
lookupRecipe :: FilePath -> [Idx.RecipeInfo] -> Maybe Idx.RecipeInfo
lookupRecipe :: FilePath -> Map 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
Map.lookup (map toLower (stripCookExt target)) recipes
-- | Strip the .cook extension if present.
stripCookExt :: FilePath -> FilePath
@@ -86,8 +166,3 @@ notFound =
HTTP.status404
[("Content-Type", "text/plain")]
"Not found"
-- | Check if an 'Either' is 'Right'.
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight (Left _) = False