From 45caffd1f4a5e731c11905ca4508c4dce71e215d Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Thu, 27 Nov 2025 18:49:44 -0500 Subject: [PATCH 1/2] wip --- README.md | 34 ++++++++++++--- src/System/UnionMount.hs | 79 ++++++++++++++++------------------- test/System/UnionMountSpec.hs | 33 ++++++++------- unionmount.cabal | 4 +- 4 files changed, 83 insertions(+), 67 deletions(-) diff --git a/README.md b/README.md index 3d6c03a..63adada 100644 --- a/README.md +++ b/README.md @@ -11,15 +11,17 @@ Here's a simple example of loading Markdown files onto a TVar of `Map FilePath T ```haskell import System.UnionMount qualified as UM import Data.Map.Strict qualified as Map +import Colog.Core (LogAction, logStringStdout, cmap) +import Data.Text qualified as T main :: IO () main = do - runStdoutLoggingT $ do - let baseDir = "/Users/srid/Documents/Notebook" - (model0, modelF) <- UM.mount baseDir (one ((), "*.md")) [] mempty (const $ handlePathUpdate baseDir) - modelVar <- newTVarIO model0 - modelF $ \newModel -> do - atomically $ writeTVar modelVar newModel + let logger = cmap T.unpack logStringStdout -- Simple stdout logger + baseDir = "/Users/srid/Documents/Notebook" + (model0, modelF) <- UM.mount logger baseDir (one ((), "*.md")) [] mempty (const $ handlePathUpdate baseDir) + modelVar <- newTVarIO model0 + modelF $ \newModel -> do + atomically $ writeTVar modelVar newModel handlePathUpdate :: (MonadIO m) => @@ -33,6 +35,26 @@ handlePathUpdate baseDir path action = do pure $ Map.delete path ``` +### Logging + +unionmount uses [co-log-core](https://hackage.haskell.org/package/co-log-core) which has zero dependencies and allows you to bring your own logging implementation: + +- **No logging**: Pass `mempty` as the logger +- **co-log**: Use any co-log logger +- **monad-logger**: Create a LogAction that calls your monad-logger functions +- **Custom**: Implement your own `LogAction m Text` + +```haskell +-- No logging +UM.mount mempty folder pats ignore model handleAction + +-- Using co-log +import Colog.Core (logStringStdout, cmap) +import Data.Text qualified as T +let logger = cmap T.unpack logStringStdout +UM.mount logger folder pats ignore model handleAction +``` + ### Examples See [this example](https://github.com/EmaApps/ema/blob/459d3899e0b9ea13e23c81126279dc62530b994c/src/Ema/Route/Lib/Extra/PandocRoute.hs#L132-L139) illustrating mounting a directory of Markdown files into (effectively) a `Map FilePath String`. A [more involved example](https://github.com/EmaApps/emanote/blob/7c49c73cd3b7dbeace72353574f3decfb68929f2/src/Emanote/Source/Dynamic.hs#L58-L64) from Emanote demonstrates the "union" aspect of the library. diff --git a/src/System/UnionMount.hs b/src/System/UnionMount.hs index 6f21e41..354d9c5 100644 --- a/src/System/UnionMount.hs +++ b/src/System/UnionMount.hs @@ -17,12 +17,8 @@ module System.UnionMount ) where +import Colog.Core (LogAction, (<&)) import Control.Concurrent (threadDelay) -import Control.Monad.Logger - ( LogLevel (LevelDebug, LevelError, LevelInfo, LevelWarn), - MonadLogger, - logWithoutLoc, - ) import Data.LVar qualified as LVar import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -49,10 +45,11 @@ mount :: forall model m b. ( MonadIO m, MonadUnliftIO m, - MonadLogger m, Show b, Ord b ) => + -- | Logger + LogAction m Text -> -- | The directory to mount. FilePath -> -- | Only include these files (exclude everything else) @@ -71,10 +68,10 @@ mount :: -- If the action throws an exception, it will be logged and ignored. (b -> FilePath -> FileAction () -> m (model -> model)) -> m (model, (model -> m ()) -> m ()) -mount folder pats ignore var0 toAction' = +mount logger folder pats ignore var0 toAction' = let tag0 = () sources = one (tag0, (folder, Nothing)) - in unionMount sources pats ignore var0 $ \ch -> do + in unionMount logger sources pats ignore var0 $ \ch -> do let fsSet = (fmap . fmap . fmap . fmap) void $ fmap Map.toList <$> Map.toList ch (\(tag, xs) -> uncurry (toAction' tag) `chainM` xs) `chainM` fsSet where @@ -95,29 +92,30 @@ unionMount :: forall source tag model m. ( MonadIO m, MonadUnliftIO m, - MonadLogger m, Ord source, Ord tag ) => + -- | Logger + LogAction m Text -> Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> model -> (Change source tag -> m (model -> model)) -> m (model, (model -> m ()) -> m ()) -unionMount sources pats ignore model0 handleAction = do - (x0, xf) <- unionMount' sources pats ignore - x0' <- interceptExceptions id $ handleAction x0 +unionMount logger sources pats ignore model0 handleAction = do + (x0, xf) <- unionMount' logger sources pats ignore + x0' <- interceptExceptions logger id $ handleAction x0 let initial = x0' model0 lvar <- LVar.new initial let sender send = do Cmd_Remount <- xf $ \change -> do - change' <- interceptExceptions id $ handleAction change + change' <- interceptExceptions logger id $ handleAction change LVar.modify lvar change' x <- LVar.get lvar send x - log LevelInfo "Remounting..." - (a, b) <- unionMount sources pats ignore model0 handleAction + logger <& "Remounting..." + (a, b) <- unionMount logger sources pats ignore model0 handleAction send a b send pure (x0' model0, sender) @@ -125,11 +123,11 @@ unionMount sources pats ignore model0 handleAction = do -- Log and ignore exceptions -- -- TODO: Make user define-able? -interceptExceptions :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => a -> m a -> m a -interceptExceptions default_ f = do +interceptExceptions :: (MonadIO m, MonadUnliftIO m) => LogAction m Text -> a -> m a -> m a +interceptExceptions logger default_ f = do try f >>= \case Left (ex :: SomeException) -> do - log LevelError $ "Change handler exception: " <> show ex + logger <& ("Change handler exception: " <> show ex) pure default_ Right v -> pure v @@ -149,30 +147,29 @@ data Cmd -- | Like `unionMount` but without exception interrupting or re-mounting. unionMount' :: - forall source tag m m1. + forall source tag m. ( MonadIO m, MonadUnliftIO m, - MonadLogger m, - MonadLogger m1, - MonadIO m1, Ord source, Ord tag ) => + -- | Logger + LogAction m Text -> Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> - m1 + m ( Change source tag, (Change source tag -> m ()) -> m Cmd ) -unionMount' sources pats ignore = do +unionMount' logger sources pats ignore = do flip evalStateT (emptyOverlayFs @source) $ do -- Initial traversal of sources changes0 :: Change source tag <- fmap snd . flip runStateT Map.empty $ do forM_ sources $ \(src, (folder, mountPoint)) -> do - taggedFiles <- filesMatchingWithTag folder pats ignore + taggedFiles <- lift . lift $ filesMatchingWithTag logger folder pats ignore forM_ taggedFiles $ \(tag, fs) -> do forM_ fs $ \fp -> do put =<< lift . changeInsert src tag mountPoint fp (Refresh Existing ()) =<< get @@ -183,7 +180,7 @@ unionMount' sources pats ignore = do -- Run fsnotify on sources q :: TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO newEmptyTMVarIO fmap (either id id) $ - race (onChange q (toList sources)) $ + race (onChange logger q (toList sources)) $ let readDebounced = do -- Wait for some initial action in the queue. _ <- atomically $ readTMVar q @@ -201,11 +198,11 @@ unionMount' sources pats ignore = do let reason = "Unhandled folder event on '" <> toText fp <> "'" if shouldIgnore then do - log LevelWarn $ reason <> " on an ignored path" + lift $ logger <& (reason <> " on an ignored path") loop else do -- We don't know yet how to deal with folder events. Just reboot the mount. - log LevelWarn $ reason <> "; suggesting a re-mount" + lift $ logger <& (reason <> "; suggesting a re-mount") pure Cmd_Remount -- Exit, asking user to remokunt Right act -> do case guard (not shouldIgnore) >> getTag pats fp of @@ -218,17 +215,17 @@ unionMount' sources pats ignore = do in evalStateT loop ofs ) -filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath] -filesMatching parent' pats ignore = do +filesMatching :: (MonadIO m) => LogAction m Text -> FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath] +filesMatching logger parent' pats ignore = do parent <- liftIO $ canonicalizePath parent' - log LevelInfo $ toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore + logger <& (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)] -> [FilePattern] -> m [(b, [FilePath])] -filesMatchingWithTag parent' pats ignore = do - fs <- filesMatching parent' (snd <$> pats) ignore +filesMatchingWithTag :: (MonadIO m, Ord b) => LogAction m Text -> FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])] +filesMatchingWithTag logger parent' pats ignore = do + fs <- filesMatching logger parent' (snd <$> pats) ignore let m = Map.fromListWith (<>) $ flip mapMaybe fs $ \fp -> do tag <- getTag pats fp @@ -279,22 +276,23 @@ refreshAction = \case onChange :: forall x m. - (Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) => + (Eq x, MonadIO m, MonadUnliftIO m) => + LogAction m Text -> TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) -> [(x, (FilePath, Maybe FilePath))] -> -- | The filepath is relative to the folder being monitored, unless if its -- ancestor is a symlink. m Cmd -onChange q roots = do +onChange logger q roots = do withManagerM $ \mgr -> do stops <- forM roots $ \(x, (rootRel, mountPoint)) -> do -- NOTE: It is important to use canonical path, because this will allow us to -- transform fsnotify event's (absolute) path into one that is relative to -- @parent'@ (as passed by user), which is what @f@ will expect. root <- liftIO $ canonicalizePath rootRel - log LevelInfo $ toText $ "Monitoring " <> root <> " for changes" + logger <& (toText $ "Monitoring " <> root <> " for changes") watchTreeM mgr root (const True) $ \event -> do - log LevelDebug $ show event + logger <& show event atomically $ do lastQ <- tryTakeTMVar q let fp = makeRelative root $ eventPath event @@ -323,7 +321,7 @@ onChange q roots = do (_, Just a) -> reAddQ >> f (Right a) liftIO (threadDelay maxBound) `finally` do - log LevelInfo "Stopping fsnotify monitor." + logger <& "Stopping fsnotify monitor." liftIO $ forM_ stops id -- Unreachable pure Cmd_Remount @@ -348,9 +346,6 @@ watchTreeM wm fp pr f = withRunInIO $ \run -> watchTree wm fp pr $ \evt -> run (f evt) -log :: (MonadLogger m) => LogLevel -> Text -> m () -log = logWithoutLoc "System.UnionMount" - -- TODO: Abstract in module with StateT / MonadState newtype OverlayFs source = OverlayFs (Map FilePath (Set (source, FilePath))) diff --git a/test/System/UnionMountSpec.hs b/test/System/UnionMountSpec.hs index cb6a7e9..5a45991 100644 --- a/test/System/UnionMountSpec.hs +++ b/test/System/UnionMountSpec.hs @@ -3,7 +3,7 @@ module System.UnionMountSpec where -import Control.Monad.Logger.Extras (logToNowhere, runLoggerLoggingT) +import Colog.Core (LogAction) import Data.LVar qualified as LVar import Data.List (stripPrefix) import Data.List.NonEmpty qualified as NE @@ -106,21 +106,22 @@ unionMountSpec :: unionMountSpec folders = do withUnionFolderMutations folders $ \tempDirs -> do model <- LVar.empty - flip runLoggerLoggingT logToNowhere $ do - let layers = Set.fromList $ toList tempDirs <&> \(folder, path) -> (path, (path, _folderMountPoint folder)) - (model0, patch) <- UM.unionMount layers allFiles ignoreNone mempty $ \change -> do - let files = Unsafe.fromJust $ Map.lookup () change - flip UM.chainM (Map.toList files) $ \(fp, act) -> do - case act of - UM.Delete -> pure $ Map.delete fp - UM.Refresh _ layerFiles -> do - contents <- for layerFiles $ \(tempDir, path) -> - readFileBS $ tempDir path - pure $ Map.insert fp contents - LVar.set model model0 - race_ - (patch $ LVar.set model) - (withPaddedThreadDelay 500_000 $ updateUnionFolderMutations tempDirs) + let logger :: LogAction IO Text + logger = mempty -- no logging + layers = Set.fromList $ toList tempDirs <&> \(folder, path) -> (path, (path, _folderMountPoint folder)) + (model0, patch) <- UM.unionMount logger layers allFiles ignoreNone mempty $ \change -> do + let files = Unsafe.fromJust $ Map.lookup () change + flip UM.chainM (Map.toList files) $ \(fp, act) -> do + case act of + UM.Delete -> pure $ Map.delete fp + UM.Refresh _ layerFiles -> do + contents <- for layerFiles $ \(tempDir, path) -> + readFileBS $ tempDir path + pure $ Map.insert fp contents + LVar.set model model0 + race_ + (patch $ LVar.set model) + (withPaddedThreadDelay 500_000 $ updateUnionFolderMutations tempDirs) finalModel <- LVar.get model expected <- runUnionFolderMutations folders finalModel `shouldBe` expected diff --git a/unionmount.cabal b/unionmount.cabal index 8114967..db82443 100644 --- a/unionmount.cabal +++ b/unionmount.cabal @@ -29,6 +29,7 @@ common library-common , async , base >=4.13.0 && <5 , bytestring + , co-log-core , containers , data-default , directory @@ -36,7 +37,6 @@ common library-common , filepattern , fsnotify >=0.4.0 && <0.5 , lvar - , monad-logger , mtl , relude , text @@ -80,8 +80,6 @@ test-suite test build-depends: , dir-traverse , hspec - , monad-logger - , monad-logger-extras , relude if flag(ghcid) From 8aff3de0f98621e83dda07a32af973989c6f2e9f Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Thu, 27 Nov 2025 19:08:29 -0500 Subject: [PATCH 2/2] sev --- README.md | 18 ++++++++---------- src/System/UnionMount.hs | 32 ++++++++++++++++---------------- test/System/UnionMountSpec.hs | 4 ++-- 3 files changed, 26 insertions(+), 28 deletions(-) diff --git a/README.md b/README.md index 63adada..951e38b 100644 --- a/README.md +++ b/README.md @@ -11,12 +11,11 @@ Here's a simple example of loading Markdown files onto a TVar of `Map FilePath T ```haskell import System.UnionMount qualified as UM import Data.Map.Strict qualified as Map -import Colog.Core (LogAction, logStringStdout, cmap) -import Data.Text qualified as T +import Colog.Core (logTextStdout, filterBySeverity, Severity (..)) main :: IO () main = do - let logger = cmap T.unpack logStringStdout -- Simple stdout logger + let logger = filterBySeverity Info Severity logTextStdout -- Log Info and above baseDir = "/Users/srid/Documents/Notebook" (model0, modelF) <- UM.mount logger baseDir (one ((), "*.md")) [] mempty (const $ handlePathUpdate baseDir) modelVar <- newTVarIO model0 @@ -37,21 +36,20 @@ handlePathUpdate baseDir path action = do ### Logging -unionmount uses [co-log-core](https://hackage.haskell.org/package/co-log-core) which has zero dependencies and allows you to bring your own logging implementation: +unionmount uses [co-log-core](https://hackage.haskell.org/package/co-log-core) which has zero dependencies and allows you to bring your own logging implementation. The logger type is `LogAction m (WithSeverity Text)`, supporting Debug, Info, Warning, and Error severity levels. - **No logging**: Pass `mempty` as the logger -- **co-log**: Use any co-log logger +- **co-log**: Use any co-log logger (with severity filtering) - **monad-logger**: Create a LogAction that calls your monad-logger functions -- **Custom**: Implement your own `LogAction m Text` +- **Custom**: Implement your own `LogAction m (WithSeverity Text)` ```haskell -- No logging UM.mount mempty folder pats ignore model handleAction --- Using co-log -import Colog.Core (logStringStdout, cmap) -import Data.Text qualified as T -let logger = cmap T.unpack logStringStdout +-- Using co-log with severity filtering +import Colog.Core (logTextStdout, filterBySeverity, Severity (..)) +let logger = filterBySeverity Info Severity logTextStdout -- Only Info and above UM.mount logger folder pats ignore model handleAction ``` diff --git a/src/System/UnionMount.hs b/src/System/UnionMount.hs index 354d9c5..d19c920 100644 --- a/src/System/UnionMount.hs +++ b/src/System/UnionMount.hs @@ -17,7 +17,7 @@ module System.UnionMount ) where -import Colog.Core (LogAction, (<&)) +import Colog.Core (LogAction, Severity (..), WithSeverity (..), (<&)) import Control.Concurrent (threadDelay) import Data.LVar qualified as LVar import Data.Map.Strict qualified as Map @@ -49,7 +49,7 @@ mount :: Ord b ) => -- | Logger - LogAction m Text -> + LogAction m (WithSeverity Text) -> -- | The directory to mount. FilePath -> -- | Only include these files (exclude everything else) @@ -96,7 +96,7 @@ unionMount :: Ord tag ) => -- | Logger - LogAction m Text -> + LogAction m (WithSeverity Text) -> Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> @@ -114,7 +114,7 @@ unionMount logger sources pats ignore model0 handleAction = do LVar.modify lvar change' x <- LVar.get lvar send x - logger <& "Remounting..." + logger <& WithSeverity "Remounting..." Info (a, b) <- unionMount logger sources pats ignore model0 handleAction send a b send @@ -123,11 +123,11 @@ unionMount logger sources pats ignore model0 handleAction = do -- Log and ignore exceptions -- -- TODO: Make user define-able? -interceptExceptions :: (MonadIO m, MonadUnliftIO m) => LogAction m Text -> a -> m a -> m a +interceptExceptions :: (MonadIO m, MonadUnliftIO m) => LogAction m (WithSeverity Text) -> a -> m a -> m a interceptExceptions logger default_ f = do try f >>= \case Left (ex :: SomeException) -> do - logger <& ("Change handler exception: " <> show ex) + logger <& WithSeverity ("Change handler exception: " <> show ex) Error pure default_ Right v -> pure v @@ -154,7 +154,7 @@ unionMount' :: Ord tag ) => -- | Logger - LogAction m Text -> + LogAction m (WithSeverity Text) -> Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> @@ -198,11 +198,11 @@ unionMount' logger sources pats ignore = do let reason = "Unhandled folder event on '" <> toText fp <> "'" if shouldIgnore then do - lift $ logger <& (reason <> " on an ignored path") + lift $ logger <& WithSeverity (reason <> " on an ignored path") Warning loop else do -- We don't know yet how to deal with folder events. Just reboot the mount. - lift $ logger <& (reason <> "; suggesting a re-mount") + lift $ logger <& WithSeverity (reason <> "; suggesting a re-mount") Warning pure Cmd_Remount -- Exit, asking user to remokunt Right act -> do case guard (not shouldIgnore) >> getTag pats fp of @@ -215,15 +215,15 @@ unionMount' logger sources pats ignore = do in evalStateT loop ofs ) -filesMatching :: (MonadIO m) => LogAction m Text -> FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath] +filesMatching :: (MonadIO m) => LogAction m (WithSeverity Text) -> FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath] filesMatching logger parent' pats ignore = do parent <- liftIO $ canonicalizePath parent' - logger <& (toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore) + logger <& WithSeverity (toText $ "Traversing " <> parent <> " for files matching " <> show pats <> ", ignoring " <> show ignore) Info 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, Ord b) => LogAction m Text -> FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])] +filesMatchingWithTag :: (MonadIO m, Ord b) => LogAction m (WithSeverity Text) -> FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])] filesMatchingWithTag logger parent' pats ignore = do fs <- filesMatching logger parent' (snd <$> pats) ignore let m = Map.fromListWith (<>) $ @@ -277,7 +277,7 @@ refreshAction = \case onChange :: forall x m. (Eq x, MonadIO m, MonadUnliftIO m) => - LogAction m Text -> + LogAction m (WithSeverity Text) -> TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) -> [(x, (FilePath, Maybe FilePath))] -> -- | The filepath is relative to the folder being monitored, unless if its @@ -290,9 +290,9 @@ onChange logger q roots = do -- transform fsnotify event's (absolute) path into one that is relative to -- @parent'@ (as passed by user), which is what @f@ will expect. root <- liftIO $ canonicalizePath rootRel - logger <& (toText $ "Monitoring " <> root <> " for changes") + logger <& WithSeverity (toText $ "Monitoring " <> root <> " for changes") Info watchTreeM mgr root (const True) $ \event -> do - logger <& show event + logger <& WithSeverity (show event) Debug atomically $ do lastQ <- tryTakeTMVar q let fp = makeRelative root $ eventPath event @@ -321,7 +321,7 @@ onChange logger q roots = do (_, Just a) -> reAddQ >> f (Right a) liftIO (threadDelay maxBound) `finally` do - logger <& "Stopping fsnotify monitor." + logger <& WithSeverity "Stopping fsnotify monitor." Info liftIO $ forM_ stops id -- Unreachable pure Cmd_Remount diff --git a/test/System/UnionMountSpec.hs b/test/System/UnionMountSpec.hs index 5a45991..148d3d6 100644 --- a/test/System/UnionMountSpec.hs +++ b/test/System/UnionMountSpec.hs @@ -3,7 +3,7 @@ module System.UnionMountSpec where -import Colog.Core (LogAction) +import Colog.Core (LogAction, WithSeverity) import Data.LVar qualified as LVar import Data.List (stripPrefix) import Data.List.NonEmpty qualified as NE @@ -106,7 +106,7 @@ unionMountSpec :: unionMountSpec folders = do withUnionFolderMutations folders $ \tempDirs -> do model <- LVar.empty - let logger :: LogAction IO Text + let logger :: LogAction IO (WithSeverity Text) logger = mempty -- no logging layers = Set.fromList $ toList tempDirs <&> \(folder, path) -> (path, (path, _folderMountPoint folder)) (model0, patch) <- UM.unionMount logger layers allFiles ignoreNone mempty $ \change -> do