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

@@ -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)

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)"

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

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