diff --git a/src/Roux/RecipeIndex.hs b/src/Roux/RecipeIndex.hs index c295625..ef59d51 100644 --- a/src/Roux/RecipeIndex.hs +++ b/src/Roux/RecipeIndex.hs @@ -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 diff --git a/src/Roux/Server.hs b/src/Roux/Server.hs index a268f96..d4449eb 100644 --- a/src/Roux/Server.hs +++ b/src/Roux/Server.hs @@ -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