unionmount 0.2.0.0 → 0.2.2.0
raw patch · 3 files changed
+85/−62 lines, 3 filesdep ~basedep ~fsnotify
Dependency ranges changed: base, fsnotify
Files
- README.md +8/−2
- src/System/UnionMount.hs +73/−57
- unionmount.cabal +4/−3
README.md view
@@ -1,5 +1,11 @@ # unionmount -Haskell library to "[union mount](https://en.wikipedia.org/wiki/Union_mount)" a bunch of folders onto an in-memory data structure, and keeping the latter in sync as the files change over time. Used in [Ema](https://ema.srid.ca) and [Emanote](https://note.ema.srid.ca).+Haskell library to "[union mount](https://en.wikipedia.org/wiki/Union_mount)" a bunch of folders onto an in-memory data structure, and keeping the latter in sync as the files change over time. Used in [Ema](https://ema.srid.ca) and [Emanote](https://emanote.srid.ca). -See [this example](https://github.com/srid/ema-template/blob/c2f1cc491aae7342ec783c87a61fbe0a73754906/src/Main.hs#L205-L213) illustrating mounting a directory of Markdown files into (effectively) a `Map FilePath String`. A [more involved example](https://github.com/srid/emanote/blob/f35d4a14cd5dfa2a871f926d8537e56908806da8/src/Emanote/Source.hs#L28-L34) from Emanote demonstrates the "union" aspect of the library.+## Usage++Both the `mount` and `unionMount` functions return a tuple value of type [Dynamic](https://ema.srid.ca/guide/model/dynamic), giving direct access to the initial value as well as the updater function that may be run in a separate thread. See [how Ema uses it](https://github.com/EmaApps/ema/blob/459d3899e0b9ea13e23c81126279dc62530b994c/src/Ema/App.hs#L72-L84) for an illustration.++### 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.
src/System/UnionMount.hs view
@@ -20,17 +20,15 @@ MonadLogger, logWithoutLoc, )-import qualified Data.LVar as LVar-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import Data.Time.Clock (NominalDiffTime)+import Data.LVar qualified as LVar+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set import System.Directory (canonicalizePath) import System.FSNotify ( ActionPredicate,- Debounce (Debounce), Event (..),+ EventIsDirectory (IsDirectory), StopListening,- WatchConfig (..), WatchManager, defaultConfig, eventIsDirectory,@@ -41,8 +39,7 @@ import System.FilePath (isRelative, makeRelative) import System.FilePattern (FilePattern, (?==)) import System.FilePattern.Directory (getDirectoryFilesIgnore)-import UnliftIO (MonadUnliftIO, finally, newTBQueueIO, race, try, withRunInIO, writeTBQueue)-import UnliftIO.STM (TBQueue, readTBQueue)+import UnliftIO (MonadUnliftIO, finally, race, try, withRunInIO) -- | Simplified version of `unionMount` with exactly one layer. mount ::@@ -79,7 +76,7 @@ (\(tag, xs) -> uncurry (toAction' tag) `chainM` xs) `chainM` fsSet where -- Monadic version of `chain`- chainM :: Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)+ chainM :: (Monad m) => (x -> m (a -> a)) -> [x] -> m (a -> a) chainM f = fmap chain . mapM f where@@ -166,7 +163,7 @@ m Cmd ) unionMount' sources pats ignore = do- fmap fst . flip runStateT (emptyOverlayFs @source) $ do+ flip evalStateT (emptyOverlayFs @source) $ do -- Initial traversal of sources changes0 :: Change source tag <- fmap snd . flip runStateT Map.empty $ do@@ -180,33 +177,41 @@ ( changes0, \reportChange -> do -- Run fsnotify on sources- q :: TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO $ newTBQueueIO 1+ q :: TMVar (x, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO newEmptyTMVarIO fmap (either id id) $ race (onChange q (toList sources)) $- fmap fst . flip runStateT ofs $ do- let loop = do- (src, fp, actE) <- atomically $ readTBQueue q- let shouldIgnore = any (?== fp) ignore- case actE of- Left _ -> do- let reason = "Unhandled folder event on '" <> toText fp <> "'"- if shouldIgnore- then do- log LevelWarn $ 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"- pure Cmd_Remount -- Exit, asking user to remokunt- Right act -> do- case guard (not shouldIgnore) >> getTag pats fp of- Nothing -> loop- Just tag -> do- changes <- fmap snd . flip runStateT Map.empty $ do- put =<< lift . changeInsert src tag fp act =<< get- lift $ reportChange changes- loop- loop+ let readDebounced = do+ -- Wait for some initial action in the queue.+ _ <- atomically $ readTMVar q+ -- 100ms is a reasonable wait period to gather (possibly related) events.+ liftIO $ threadDelay 100000+ -- If after this period the queue is empty again, retry.+ -- (this can happen if a file is created and deleted in this short span)+ maybe readDebounced pure+ =<< atomically (tryTakeTMVar q)+ loop = do+ (src, fp, actE) <- readDebounced+ let shouldIgnore = any (?== fp) ignore+ case actE of+ Left _ -> do+ let reason = "Unhandled folder event on '" <> toText fp <> "'"+ if shouldIgnore+ then do+ log LevelWarn $ 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"+ pure Cmd_Remount -- Exit, asking user to remokunt+ Right act -> do+ case guard (not shouldIgnore) >> getTag pats fp of+ Nothing -> loop+ Just tag -> do+ changes <- fmap snd . flip runStateT Map.empty $ do+ put =<< lift . changeInsert src tag fp act =<< get+ lift $ reportChange changes+ loop+ in evalStateT loop ofs ) filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath]@@ -230,8 +235,8 @@ getTag pats fp = let pull patterns = listToMaybe $- flip mapMaybe patterns $ \(tag, pattern) -> do- guard $ pattern ?== fp+ flip mapMaybe patterns $ \(tag, pat) -> do+ guard $ pat ?== fp pure tag in if isRelative fp then pull pats@@ -270,19 +275,14 @@ onChange :: forall x m.- (MonadIO m, MonadLogger m, MonadUnliftIO m) =>- TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ())) ->+ (Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) =>+ TMVar (x, FilePath, Either (FolderAction ()) (FileAction ())) -> [(x, FilePath)] -> -- | The filepath is relative to the folder being monitored, unless if its -- ancestor is a symlink. m Cmd onChange q roots = do- -- 100ms is a reasonable wait period to gather (possibly related) events.- -- One such related event is a MOVE, which fsnotify doesn't native support;- -- and spits out a DELETE and ADD instead.- let debounceDurationSecs :: NominalDiffTime = 0.1- cfg = defaultConfig {confDebounce = Debounce debounceDurationSecs}- withManagerM cfg $ \mgr -> do+ withManagerM $ \mgr -> do stops <- forM roots $ \(x, rootRel) -> 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@@ -291,15 +291,32 @@ log LevelInfo $ toText $ "Monitoring " <> root <> " for changes" watchTreeM mgr root (const True) $ \event -> do log LevelDebug $ show event- let rel = makeRelative root- f a fp act = atomically $ writeTBQueue q (a, fp, act)- if eventIsDirectory event- then f x (rel . eventPath $ event) $ Left $ FolderAction ()- else case event of- Added (rel -> fp) _ _ -> f x fp $ Right $ Refresh New ()- Modified (rel -> fp) _ _ -> f x fp $ Right $ Refresh Update ()- Removed (rel -> fp) _ _ -> f x fp $ Right Delete- Unknown (rel -> fp) _ _ -> f x fp $ Right Delete+ atomically $ do+ lastQ <- tryTakeTMVar q+ let fp = makeRelative root $ eventPath event+ f act = putTMVar q (x, fp, act)+ -- Re-add last item to the queue+ reAddQ = forM_ lastQ (putTMVar q)+ if eventIsDirectory event == IsDirectory+ then f $ Left $ FolderAction ()+ else do+ let newAction = case event of+ Added {} -> Just $ Refresh New ()+ Modified {} -> Just $ Refresh Update ()+ ModifiedAttributes {} -> Just $ Refresh Update ()+ Removed {} -> Just Delete+ _ -> Nothing+ -- Merge with the last action when it makes sense to do so.+ case (lastQ, newAction) of+ (_, Nothing) -> reAddQ+ (Just (lastTag, lastFp, Right lastAction), Just a)+ | lastTag == x && lastFp == fp ->+ case (lastAction, a) of+ (Delete, Refresh New ()) -> f $ Right $ Refresh Update ()+ (Refresh New (), Refresh Update ()) -> f $ Right $ Refresh New ()+ (Refresh New (), Delete) -> pure ()+ _ -> f $ Right a+ (_, Just a) -> reAddQ >> f (Right a) liftIO (threadDelay maxBound) `finally` do log LevelInfo "Stopping fsnotify monitor."@@ -309,12 +326,11 @@ withManagerM :: (MonadIO m, MonadUnliftIO m) =>- WatchConfig -> (WatchManager -> m a) -> m a-withManagerM cfg f = do+withManagerM f = do withRunInIO $ \run ->- withManagerConf cfg $ \mgr -> run (f mgr)+ withManagerConf defaultConfig $ \mgr -> run (f mgr) watchTreeM :: forall m.
unionmount.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: unionmount-version: 0.2.0.0+version: 0.2.2.0 license: MIT copyright: 2021 Sridhar Ratnakumar maintainer: srid@srid.ca@@ -23,14 +23,14 @@ library build-depends: , async- , base >=4.13.0.0 && <=4.17.0.0+ , base >=4.13.0 && <4.18 , bytestring , containers , data-default , directory , filepath , filepattern- , fsnotify+ , fsnotify >=0.4.0 && <0.5 , lvar , monad-logger , mtl@@ -52,6 +52,7 @@ default-extensions: FlexibleContexts FlexibleInstances+ ImportQualifiedPost KindSignatures LambdaCase MultiParamTypeClasses