From edd49514bf9a484498f3a581b7ed403bd65bb828 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar <3998+srid@users.noreply.github.com> Date: Fri, 21 May 2021 20:41:21 -0400 Subject: [PATCH] Model-dependent static assets (#37) * Have staticAssets take model as argument Make server lenient * FileSystem: allow ignoring patterns, eg: .git * Match tag in order * Fix ?== argument order * refactor --- src/Ema/App.hs | 12 ++++++------ src/Ema/Generate.hs | 2 ++ src/Ema/Helper/FileSystem.hs | 34 +++++++++++++++++++++------------- src/Ema/Server.hs | 13 +++---------- 4 files changed, 32 insertions(+), 29 deletions(-) diff --git a/src/Ema/App.hs b/src/Ema/App.hs index 1f941f7..15f603f 100644 --- a/src/Ema/App.hs +++ b/src/Ema/App.hs @@ -37,7 +37,7 @@ runEmaPure :: (CLI.Action -> LByteString) -> IO () runEmaPure render = do - runEma [] (const [()]) (\act () () -> render act) $ \model -> do + runEma (const []) (const $ one ()) (\act () () -> render act) $ \model -> do LVar.set model () liftIO $ threadDelay maxBound @@ -49,7 +49,7 @@ runEmaPure render = do runEma :: forall model route. (FileRoute route, Show route) => - [FilePath] -> + (model -> [FilePath]) -> (model -> [route]) -> -- | How to render a route, given the model (CLI.Action -> model -> route -> LByteString) -> @@ -68,7 +68,7 @@ runEmaWithCli :: forall model route. (FileRoute route, Show route) => Cli -> - [FilePath] -> + (model -> [FilePath]) -> (model -> [route]) -> -- | How to render a route, given the model (CLI.Action -> model -> route -> LByteString) -> @@ -103,7 +103,7 @@ runEmaWithCliInCwd :: -- or @Data.LVar.modify@ to modify it. Ema will automatically hot-reload your -- site as this model data changes. LVar model -> - [FilePath] -> + (model -> [FilePath]) -> (model -> [route]) -> -- | Your site render function. Takes the current @model@ value, and the page -- @route@ type as arguments. It must return the raw HTML to render to browser @@ -114,8 +114,8 @@ runEmaWithCliInCwd cliAction model staticAssets staticRoutes render = do case cliAction of Generate dest -> do val <- LVar.get model - Generate.generate dest val staticAssets (staticRoutes val) (render cliAction) + Generate.generate dest val (staticAssets val) (staticRoutes val) (render cliAction) Run -> do void $ LVar.get model port <- liftIO $ fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT" - Server.runServerWithWebSocketHotReload port model staticAssets (render cliAction) + Server.runServerWithWebSocketHotReload port model (render cliAction) diff --git a/src/Ema/Generate.hs b/src/Ema/Generate.hs index 308cd4d..f075d27 100644 --- a/src/Ema/Generate.hs +++ b/src/Ema/Generate.hs @@ -42,6 +42,8 @@ generate dest model staticAssets routes render = do forM_ staticAssets $ \staticPath -> do liftIO (doesPathExist staticPath) >>= \case True -> + -- TODO: In current branch, we don't expect this to be a directory. + -- Although the user may pass it, but review before merge. copyDirRecursively staticPath dest False -> log LevelWarn $ toText $ "? " <> staticPath <> " (missing)" diff --git a/src/Ema/Helper/FileSystem.hs b/src/Ema/Helper/FileSystem.hs index dbf24cb..6daadf1 100644 --- a/src/Ema/Helper/FileSystem.hs +++ b/src/Ema/Helper/FileSystem.hs @@ -35,8 +35,8 @@ import System.FSNotify withManager, ) import System.FilePath (isRelative, makeRelative) -import System.FilePattern (FilePattern, matchMany) -import System.FilePattern.Directory (getDirectoryFiles) +import System.FilePattern (FilePattern, matchMany, (?==)) +import System.FilePattern.Directory (getDirectoryFilesIgnore) import UnliftIO (MonadUnliftIO, toIO, withRunInIO) -- | Mount the given directory on to the given LVar such that any filesystem @@ -54,6 +54,8 @@ mountOnLVar :: FilePath -> -- | Only include these files (exclude everything else) [(b, FilePattern)] -> + -- | Ignore these patterns + [FilePattern] -> -- | The `LVar` onto which to mount. -- -- NOTE: It must not be set already. Otherwise, the value will be overriden @@ -71,15 +73,18 @@ mountOnLVar :: -- If the action throws an exception, it will be logged and ignored. ([(b, [FilePath])] -> FileAction -> m (model -> model)) -> m () -mountOnLVar folder pats var var0 toAction' = do +mountOnLVar folder pats ignore var var0 toAction' = do let toAction x = interceptExceptions id . toAction' x log LevelInfo $ "Mounting path " <> toText folder <> " (filter: " <> show pats <> ") onto LVar" LVar.set var =<< do - fs <- filesMatchingWithTag folder pats + fs <- filesMatchingWithTag folder pats ignore initialAction <- toAction fs Update pure $ initialAction var0 onChange folder $ \fp change -> do - whenJust (getTag pats fp) $ \tag -> do + -- TODO: Should refactor the ignore part to be integral to pats, and be part + -- of `getTag` + let shouldIgnore = any (?== fp) ignore + whenJust (guard (not shouldIgnore) >> getTag pats fp) $ \tag -> do -- TODO: We should probably debounce and group frequently-firing events -- here, but do so such that `change` is the same for the events in the -- group. @@ -98,17 +103,17 @@ mountOnLVar folder pats var var0 toAction' = do Right v -> pure v -filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> m [FilePath] -filesMatching parent' pats = do +filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath] +filesMatching parent' pats ignore = do parent <- liftIO $ canonicalizePath parent' - log LevelInfo $ toText $ "Traversing " <> parent <> " for files matching " <> show pats - liftIO $ getDirectoryFiles parent pats + log LevelInfo $ toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore + liftIO $ getDirectoryFilesIgnore parent pats ignore -- | Like `filesMatching` but with a tag associated with a pattern so as to be -- able to tell which pattern a resulting filepath is associated with. -filesMatchingWithTag :: (MonadIO m, MonadLogger m, Ord b) => FilePath -> [(b, FilePattern)] -> m [(b, [FilePath])] -filesMatchingWithTag parent' pats = do - fs <- filesMatching parent' (snd <$> pats) +filesMatchingWithTag :: (MonadIO m, MonadLogger m, Ord b) => FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])] +filesMatchingWithTag parent' pats ignore = do + fs <- filesMatching parent' (snd <$> pats) ignore let m = Map.fromListWith (<>) $ flip mapMaybe fs $ \fp -> do tag <- getTag pats fp @@ -118,7 +123,10 @@ filesMatchingWithTag parent' pats = do getTag :: [(b, FilePattern)] -> FilePath -> Maybe b getTag pats fp = let pull patterns = - fmap (\(x, (), _) -> x) $ listToMaybe $ matchMany patterns (one ((), fp)) + listToMaybe $ + flip mapMaybe patterns $ \(tag, pattern) -> do + guard $ pattern ?== fp + pure tag in if isRelative fp then pull pats else -- `fp` is an absolute path (because of use of symlinks), so let's diff --git a/src/Ema/Server.hs b/src/Ema/Server.hs index 9477ebc..b087588 100644 --- a/src/Ema/Server.hs +++ b/src/Ema/Server.hs @@ -20,7 +20,6 @@ import qualified Network.Wai.Handler.WebSockets as WaiWs import qualified Network.Wai.Middleware.Static as Static import Network.WebSockets (ConnectionException) import qualified Network.WebSockets as WS -import Relude.Extra.Foldable1 (foldl1') import Text.Printf (printf) import UnliftIO (MonadUnliftIO) @@ -34,10 +33,9 @@ runServerWithWebSocketHotReload :: ) => Int -> LVar model -> - [FilePath] -> (model -> route -> LByteString) -> m () -runServerWithWebSocketHotReload port model staticAssets render = do +runServerWithWebSocketHotReload port model render = do let settings = Warp.setPort port Warp.defaultSettings logger <- askLoggerIO @@ -102,13 +100,8 @@ runServerWithWebSocketHotReload port model staticAssets render = do Left (err :: ConnectionException) -> do log LevelError $ "Websocket error: " <> show err LVar.removeListener model subId - assetsMiddleware = do - case nonEmpty staticAssets of - Nothing -> id - Just topLevelPaths -> - let assetPolicy :: Static.Policy = - foldl1' (Static.<|>) $ Static.hasPrefix <$> topLevelPaths - in Static.staticPolicy assetPolicy + assetsMiddleware = + Static.static httpApp logger req f = do flip runLoggingT logger $ do let path = Wai.pathInfo req