diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/src/System/UnionMount.hs b/src/System/UnionMount.hs --- a/src/System/UnionMount.hs +++ b/src/System/UnionMount.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/System/UnionMountSpec.hs b/test/System/UnionMountSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/UnionMountSpec.hs @@ -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 = [] diff --git a/unionmount.cabal b/unionmount.cabal --- a/unionmount.cabal +++ b/unionmount.cabal @@ -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