unionmount 0.2.2.0 → 0.3.0.0
raw patch · 5 files changed
+329/−44 lines, 5 filesdep +dir-traversedep +hspecdep +monad-logger-extrasdep ~base
Dependencies added: dir-traverse, hspec, monad-logger-extras, unionmount
Dependency ranges changed: base
Files
- README.md +27/−0
- src/System/UnionMount.hs +45/−39
- test/Spec.hs +1/−0
- test/System/UnionMountSpec.hs +225/−0
- unionmount.cabal +31/−5
README.md view
@@ -6,6 +6,33 @@ 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. +Here's a simple example of loading Markdown files onto a TVar of `Map FilePath Text` (file contents keyed by path).++```haskell+import System.UnionMount qualified as UM+import Data.Map.Strict qualified as Map++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++handlePathUpdate ::+ (MonadIO m) =>+ FilePath -> FilePath -> UM.FileAction () -> m (Map FilePath Text -> Map FilePath Text)+handlePathUpdate baseDir path action = do+ case action of+ UM.Refresh _ _ -> do+ s <- decodeUtf8 <$> readFileBS (baseDir </> path)+ pure $ Map.insert path s+ UM.Delete -> do+ pure $ Map.delete path+```+ ### 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
@@ -11,6 +11,9 @@ FileAction (..), RefreshAction (..), Change,++ -- * For tests+ chainM, ) where @@ -36,7 +39,7 @@ watchTree, withManagerConf, )-import System.FilePath (isRelative, makeRelative)+import System.FilePath (isRelative, makeRelative, (</>)) import System.FilePattern (FilePattern, (?==)) import System.FilePattern.Directory (getDirectoryFilesIgnore) import UnliftIO (MonadUnliftIO, finally, race, try, withRunInIO)@@ -70,22 +73,23 @@ m (model, (model -> m ()) -> m ()) mount folder pats ignore var0 toAction' = let tag0 = ()- sources = one (tag0, folder)+ sources = one (tag0, (folder, Nothing)) in unionMount 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- -- Monadic version of `chain`- chainM :: (Monad m) => (x -> m (a -> a)) -> [x] -> m (a -> a)- chainM f =- fmap chain . mapM f- where- -- Apply the list of actions in the given order to an initial argument.- --- -- chain [f1, f2, ...] a = ... (f2 (f1 x))- chain :: [a -> a] -> a -> a- chain = flip $ foldl' $ flip ($) +-- Monadic version of `chain`+chainM :: (Monad m) => (x -> m (a -> a)) -> [x] -> m (a -> a)+chainM f =+ fmap chain . mapM f+ where+ -- Apply the list of actions in the given order to an initial argument.+ --+ -- chain [f1, f2, ...] a = ... (f2 (f1 x))+ chain :: [a -> a] -> a -> a+ chain = flip $ foldl' $ flip ($)+ -- | Union mount a set of sources (directories) into a model. unionMount :: forall source tag model m.@@ -95,7 +99,7 @@ Ord source, Ord tag ) =>- Set (source, FilePath) ->+ Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> model ->@@ -154,7 +158,7 @@ Ord source, Ord tag ) =>- Set (source, FilePath) ->+ Set (source, (FilePath, Maybe FilePath)) -> [(tag, FilePattern)] -> [FilePattern] -> m1@@ -167,17 +171,17 @@ -- Initial traversal of sources changes0 :: Change source tag <- fmap snd . flip runStateT Map.empty $ do- forM_ sources $ \(src, folder) -> do+ forM_ sources $ \(src, (folder, mountPoint)) -> do taggedFiles <- filesMatchingWithTag folder pats ignore forM_ taggedFiles $ \(tag, fs) -> do forM_ fs $ \fp -> do- put =<< lift . changeInsert src tag fp (Refresh Existing ()) =<< get+ put =<< lift . changeInsert src tag mountPoint fp (Refresh Existing ()) =<< get ofs <- get pure ( changes0, \reportChange -> do -- Run fsnotify on sources- q :: TMVar (x, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO newEmptyTMVarIO+ q :: TMVar (x, Maybe FilePath, FilePath, Either (FolderAction ()) (FileAction ())) <- liftIO newEmptyTMVarIO fmap (either id id) $ race (onChange q (toList sources)) $ let readDebounced = do@@ -190,7 +194,7 @@ maybe readDebounced pure =<< atomically (tryTakeTMVar q) loop = do- (src, fp, actE) <- readDebounced+ (src, mountPoint, fp, actE) <- readDebounced let shouldIgnore = any (?== fp) ignore case actE of Left _ -> do@@ -208,7 +212,7 @@ Nothing -> loop Just tag -> do changes <- fmap snd . flip runStateT Map.empty $ do- put =<< lift . changeInsert src tag fp act =<< get+ put =<< lift . changeInsert src tag mountPoint fp act =<< get lift $ reportChange changes loop in evalStateT loop ofs@@ -276,14 +280,14 @@ onChange :: forall x m. (Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) =>- TMVar (x, FilePath, Either (FolderAction ()) (FileAction ())) ->- [(x, FilePath)] ->+ 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 withManagerM $ \mgr -> do- stops <- forM roots $ \(x, rootRel) -> 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.@@ -294,7 +298,7 @@ atomically $ do lastQ <- tryTakeTMVar q let fp = makeRelative root $ eventPath event- f act = putTMVar q (x, fp, act)+ f act = putTMVar q (x, mountPoint, fp, act) -- Re-add last item to the queue reAddQ = forM_ lastQ (putTMVar q) if eventIsDirectory event == IsDirectory@@ -309,7 +313,7 @@ -- 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)+ (Just (lastTag, _lastMountPoint, lastFp, Right lastAction), Just a) | lastTag == x && lastFp == fp -> case (lastAction, a) of (Delete, Refresh New ()) -> f $ Right $ Refresh Update ()@@ -344,30 +348,30 @@ withRunInIO $ \run -> watchTree wm fp pr $ \evt -> run (f evt) -log :: MonadLogger m => LogLevel -> Text -> m ()+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))+newtype OverlayFs source = OverlayFs (Map FilePath (Set (source, FilePath))) -- TODO: Replace this with a function taking `NonEmpty source`-emptyOverlayFs :: Ord source => OverlayFs source+emptyOverlayFs :: (Ord source) => OverlayFs source emptyOverlayFs = OverlayFs mempty -overlayFsModify :: FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src+overlayFsModify :: FilePath -> (Set (src, FilePath) -> Set (src, FilePath)) -> OverlayFs src -> OverlayFs src overlayFsModify k f (OverlayFs m) = OverlayFs $ Map.insert k (f $ fromMaybe Set.empty $ Map.lookup k m) m -overlayFsAdd :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src+overlayFsAdd :: (Ord src) => FilePath -> (src, FilePath) -> OverlayFs src -> OverlayFs src overlayFsAdd fp src = overlayFsModify fp $ Set.insert src -overlayFsRemove :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src+overlayFsRemove :: (Ord src) => FilePath -> (src, FilePath) -> OverlayFs src -> OverlayFs src overlayFsRemove fp src = overlayFsModify fp $ Set.delete src -overlayFsLookup :: FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))+overlayFsLookup :: FilePath -> OverlayFs source -> Maybe (NonEmpty ((source, FilePath), FilePath)) overlayFsLookup fp (OverlayFs m) = do sources <- nonEmpty . toList =<< Map.lookup fp m pure $ sources <&> (,fp)@@ -382,29 +386,31 @@ (Ord source, Ord tag, MonadState (OverlayFs source) m) => source -> tag ->+ Maybe FilePath -> FilePath -> FileAction () -> Change source tag -> m (Change source tag)-changeInsert src tag fp act ch = do+changeInsert src tag mountPoint fp act ch = do+ let fpMounted = maybe fp (</> fp) mountPoint fmap snd . flip runStateT ch $ do -- First, register this change in the overlayFs lift $ modify $ (if act == Delete then overlayFsRemove else overlayFsAdd)- fp- src- overlays <-- lift (gets $ overlayFsLookup fp) <&> \case+ fpMounted+ (src, fp)+ overlays :: FileAction (NonEmpty (source, FilePath)) <-+ lift (gets $ overlayFsLookup fpMounted) <&> \case Nothing -> Delete Just fs -> -- We don't track per-source action (not ideal), so use 'Existing' -- only if the current action is 'Deleted'. In every other scenario, -- re-use the current action for all overlay files. let combinedAction = fromMaybe Existing $ refreshAction act- in Refresh combinedAction fs+ in Refresh combinedAction $ fs <&> \((src', fp'), _) -> (src', fp') gets (Map.lookup tag) >>= \case Nothing ->- modify $ Map.insert tag $ Map.singleton fp overlays+ modify $ Map.insert tag $ Map.singleton fpMounted overlays Just files ->- modify $ Map.insert tag $ Map.insert fp overlays files+ modify $ Map.insert tag $ Map.insert fpMounted overlays files
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/System/UnionMountSpec.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE NumericUnderscores #-}++module System.UnionMountSpec where++import Control.Monad.Logger.Extras (logToNowhere, runLoggerLoggingT)+import Data.LVar qualified as LVar+import Data.List (stripPrefix)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Traversable (for)+import Relude.Unsafe qualified as Unsafe+import System.Directory (createDirectory)+import System.Directory.Recursive (getFilesRecursive)+import System.FilePath ((</>))+import System.FilePattern (FilePattern)+import System.UnionMount qualified as UM+import Test.Hspec+import UnliftIO (MonadUnliftIO)+import UnliftIO.Async (race_)+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Directory (removeFile, withCurrentDirectory)+import UnliftIO.Temporary (withSystemTempDirectory)++spec :: Spec+spec = do+ -- TODO: Use QuickCheck to generate these.+ describe "unionmount" $ do+ it "basic" $ do+ unionMountSpec $+ one $+ FolderMutation+ Nothing+ ( do+ writeFile "file1" "hello"+ )+ ( do+ writeFile "file1" "hello, again"+ writeFile "file2" "another file"+ )+ it "deletion" $ do+ unionMountSpec $+ one $+ FolderMutation+ Nothing+ ( do+ writeFile "file1" "hello"+ writeFile "file2" "another file"+ )+ ( do+ writeFile "file1" "hello, again"+ removeFile "file2"+ )+ it "multiple layers" $ do+ unionMountSpec $+ FolderMutation+ Nothing+ ( do+ writeFile "file1" "hello"+ writeFile "file3" "hello"+ )+ ( do+ writeFile "file1" "hello, again"+ )+ :| [ FolderMutation+ Nothing+ ( do+ writeFile "file2" "another file"+ )+ ( do+ writeFile "file2" "another file, again"+ writeFile "file3" "file3 is in first layer"+ )+ ]+ it "mount point layers" $ do+ unionMountSpec $+ FolderMutation+ Nothing+ ( do+ writeFile "file1" "hello"+ writeFile "file3" "hello"+ )+ ( do+ writeFile "file1" "hello, again"+ )+ :| [ FolderMutation+ (Just "foo")+ ( do+ writeFile "file2" "another file"+ )+ ( do+ writeFile "file2" "another file, again"+ writeFile "file3" "file3 is in first layer"+ )+ ]++-- | Test `UM.unionMount` on a set of folders whose contents/mutations are+-- represented by a `FolderMutation`, and check that the resulting model is+-- equivalent to the state when these mutations are applied in normal IO context+-- (outside of unionmount).+unionMountSpec ::+ -- | The folder mutations to test+ UnionFolderMutations ->+ Expectation+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)+ finalModel <- LVar.get model+ expected <- runUnionFolderMutations folders+ finalModel `shouldBe` expected+ print expected+ where+ -- NOTE: These timings may not be enough on a slow system.+ withPaddedThreadDelay :: (MonadUnliftIO m) => Int -> m () -> m ()+ withPaddedThreadDelay padding action = do+ -- Wait for the initial model to be loaded.+ threadDelay padding+ action+ -- Wait for fsnotify to handle events+ threadDelay padding++-- | Represent the mutation of a folder over time.+--+-- Initial state of the folder, along with the mutations to perform, both as IO+-- actions.+data FolderMutation = FolderMutation+ { -- Mount point: the subfolder in which files must be shifted.+ _folderMountPoint :: Maybe FilePath,+ -- | How to initialize the folder+ _folderMutationInit :: IO (),+ -- | IO operations to perform for updating the folder+ _folderMutationUpdate :: IO ()+ }++runFolderMutation :: FolderMutation -> IO (Map.Map FilePath ByteString)+runFolderMutation folder = do+ withSystemTempDirectory "runFolderMutation" $ \tempDir -> do+ withCurrentDirectory tempDir $ do+ let withMountPointIfAny = case _folderMountPoint folder of+ Nothing -> id+ Just subdir -> \f -> do+ -- Create the mount point+ _ <- createDirectory subdir+ withCurrentDirectory subdir f+ withMountPointIfAny $ do+ _folderMutationInit folder+ _folderMutationUpdate folder+ files <- getFilesRecursiveCurrentDir+ Map.fromList <$> forM files (\f -> (f,) <$> readFileBS f)+ where+ getFilesRecursiveCurrentDir :: IO [FilePath]+ getFilesRecursiveCurrentDir = do+ fs <- getFilesRecursive "."+ -- Remove the leading "./" from the file paths+ pure $ fs <&> \f -> fromMaybe f $ stripPrefix "./" f++-- | A non-empty list of folder mutations that are meant to be unioned together.+type UnionFolderMutations = NonEmpty FolderMutation++runUnionFolderMutations :: UnionFolderMutations -> IO (Map.Map FilePath (NonEmpty ByteString))+runUnionFolderMutations folders =+ Map.unionsWith (<>) . fmap (Map.map one) <$> traverse runFolderMutation folders++-- | Create a temp directory for each folder in the list, and call the handler.+--+-- Also initialize each folders. Use `updateUnionFolderMutations` to update the+-- folders. And `runUnionFolderMutations` to get the final state of the folders,+-- with values unioned as lists.+withUnionFolderMutations ::+ (MonadUnliftIO m) =>+ UnionFolderMutations ->+ (NonEmpty (FolderMutation, FilePath) -> m a) ->+ m a+withUnionFolderMutations folders f = do+ withSystemTempDirectories folders $ \tempDirs -> do+ forM_ tempDirs $ \(folder, tempDir) ->+ liftIO $ withCurrentDirectory tempDir $ _folderMutationInit folder+ f tempDirs++updateUnionFolderMutations ::+ (MonadUnliftIO m) =>+ NonEmpty (FolderMutation, FilePath) ->+ m ()+updateUnionFolderMutations tempDirs = do+ forM_ tempDirs $ \(folder, tempDir) ->+ liftIO $ withCurrentDirectory tempDir $ _folderMutationUpdate folder++-- | Like `withSystemTempDirectory`, but for multiple temp directories.+withSystemTempDirectories ::+ (MonadUnliftIO m) =>+ -- | Create a temp directory for each tag in this list.+ NonEmpty tag ->+ -- | The handler is passed the temp directory along with the associated tag.+ (NonEmpty (tag, FilePath) -> m a) ->+ m a+withSystemTempDirectories = go mempty+ where+ go acc (tag :| []) f =+ withSystemTempDirectory "withSystemTempDirectories" $ \dir ->+ f $ NE.reverse $ (tag, dir) :| acc+ go acc (tag :| (t : ts)) f =+ withSystemTempDirectory "withSystemTempDirectories" $ \dir ->+ go ((tag, dir) : acc) (t :| ts) f++allFiles :: [((), FilePattern)]+allFiles = [((), "*")]++ignoreNone :: [a]+ignoreNone = []
unionmount.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: unionmount-version: 0.2.2.0+version: 0.3.0.0 license: MIT copyright: 2021 Sridhar Ratnakumar maintainer: srid@srid.ca@@ -20,10 +20,14 @@ LICENSE README.md -library+flag ghcid+ default: False+ manual: True++common library-common build-depends: , async- , base >=4.13.0 && <4.18+ , base >=4.13.0 && <5 , bytestring , containers , data-default@@ -48,7 +52,6 @@ ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns - exposed-modules: System.UnionMount default-extensions: FlexibleContexts FlexibleInstances@@ -62,5 +65,28 @@ TupleSections ViewPatterns - hs-source-dirs: src default-language: Haskell2010++library+ import: library-common+ exposed-modules: System.UnionMount+ hs-source-dirs: src++test-suite test+ import: library-common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ , dir-traverse+ , hspec+ , monad-logger+ , monad-logger-extras+ , relude++ if flag(ghcid)+ hs-source-dirs: src++ else+ build-depends: unionmount+ other-modules: System.UnionMountSpec