{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}

module System.UnionMount
  ( -- * Mount endpoints
    mount,
    unionMount,
    unionMount',

    -- * Types
    FileAction (..),
    RefreshAction (..),
    Change,
  )
where

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
import System.Directory (canonicalizePath)
import System.FSNotify
  ( ActionPredicate,
    Event (..),
    EventIsDirectory (IsDirectory),
    StopListening,
    WatchManager,
    defaultConfig,
    eventIsDirectory,
    eventPath,
    watchTree,
    withManagerConf,
  )
import System.FilePath (isRelative, makeRelative)
import System.FilePattern (FilePattern, (?==))
import System.FilePattern.Directory (getDirectoryFilesIgnore)
import UnliftIO (MonadUnliftIO, finally, race, try, withRunInIO)

-- | Simplified version of `unionMount` with exactly one layer.
mount ::
  forall model m b.
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLogger m,
    Show b,
    Ord b
  ) =>
  -- | The directory to mount.
  FilePath ->
  -- | Only include these files (exclude everything else)
  [(b, FilePattern)] ->
  -- | Ignore these patterns
  [FilePattern] ->
  -- | Initial value of model, onto which to apply updates.
  model ->
  -- | How to update the model given a file action.
  --
  -- `b` is the tag associated with the `FilePattern` that selected this
  -- `FilePath`. `FileAction` is the operation performed on this path. This
  -- should return a function (in monadic context) that will update the model,
  -- to reflect the given `FileAction`.
  --
  -- If the action throws an exception, it will be logged and ignored.
  (b -> FilePath -> FileAction () -> m (model -> model)) ->
  m (model, (model -> m ()) -> m ())
mount :: forall model (m :: * -> *) b.
(MonadIO m, MonadUnliftIO m, MonadLogger m, Show b, Ord b) =>
FilePath
-> [(b, FilePath)]
-> [FilePath]
-> model
-> (b -> FilePath -> FileAction () -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
mount FilePath
folder [(b, FilePath)]
pats [FilePath]
ignore model
var0 b -> FilePath -> FileAction () -> m (model -> model)
toAction' =
  let tag0 :: ()
tag0 = ()
      sources :: Set ((), FilePath)
sources = forall x. One x => OneItem x -> x
one (()
tag0, FilePath
folder)
   in forall source tag model (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set ((), FilePath)
sources [(b, FilePath)]
pats [FilePath]
ignore model
var0 forall a b. (a -> b) -> a -> b
$ \Change () b
ch -> do
        let fsSet :: [(b, [(FilePath, FileAction ())])]
fsSet = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Map k a -> [(k, a)]
Map.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Change () b
ch
        (\(b
tag, [(FilePath, FileAction ())]
xs) -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (b -> FilePath -> FileAction () -> m (model -> model)
toAction' b
tag) forall x a. Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
`chainM` [(FilePath, FileAction ())]
xs) forall x a. Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
`chainM` [(b, [(FilePath, FileAction ())])]
fsSet
  where
    -- Monadic version of `chain`
    chainM :: (Monad m) => (x -> m (a -> a)) -> [x] -> m (a -> a)
    chainM :: forall x a. Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
chainM x -> m (a -> a)
f =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a -> a] -> a -> a
chain forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM x -> m (a -> a)
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 :: forall a. [a -> a] -> a -> a
chain = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)

-- | Union mount a set of sources (directories) into a model.
unionMount ::
  forall source tag model m.
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLogger m,
    Ord source,
    Ord tag
  ) =>
  Set (source, FilePath) ->
  [(tag, FilePattern)] ->
  [FilePattern] ->
  model ->
  (Change source tag -> m (model -> model)) ->
  m (model, (model -> m ()) -> m ())
unionMount :: forall source tag model (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore model
model0 Change source tag -> m (model -> model)
handleAction = do
  (Change source tag
x0, (Change source tag -> m ()) -> m Cmd
xf) <- forall source tag (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLogger m1,
 MonadIO m1, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
unionMount' Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore
  model -> model
x0' <- forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
interceptExceptions forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Change source tag -> m (model -> model)
handleAction Change source tag
x0
  let initial :: model
initial = model -> model
x0' model
model0
  LVar model
lvar <- forall a (m :: * -> *). MonadIO m => a -> m (LVar a)
LVar.new model
initial
  let sender :: (model -> m ()) -> m ()
sender model -> m ()
send = do
        Cmd
Cmd_Remount <- (Change source tag -> m ()) -> m Cmd
xf forall a b. (a -> b) -> a -> b
$ \Change source tag
change -> do
          model -> model
change' <- forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
interceptExceptions forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Change source tag -> m (model -> model)
handleAction Change source tag
change
          forall (m :: * -> *) a. MonadIO m => LVar a -> (a -> a) -> m ()
LVar.modify LVar model
lvar model -> model
change'
          model
x <- forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
lvar
          model -> m ()
send model
x
        forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo Text
"Remounting..."
        (model
a, (model -> m ()) -> m ()
b) <- forall source tag model (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore model
model0 Change source tag -> m (model -> model)
handleAction
        model -> m ()
send model
a
        (model -> m ()) -> m ()
b model -> m ()
send
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> model
x0' model
model0, (model -> m ()) -> m ()
sender)

-- Log and ignore exceptions
--
-- TODO: Make user define-able?
interceptExceptions :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => a -> m a -> m a
interceptExceptions :: forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
interceptExceptions a
default_ m a
f = do
  forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try m a
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (SomeException
ex :: SomeException) -> do
      forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelError forall a b. (a -> b) -> a -> b
$ Text
"Change handler exception: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show SomeException
ex
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
default_
    Right a
v ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

-------------------------------------
-- Candidate for moving to a library
-------------------------------------

data Evt source tag
  = Evt_Change (Change source tag)
  | Evt_Unhandled
  deriving (Evt source tag -> Evt source tag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
/= :: Evt source tag -> Evt source tag -> Bool
$c/= :: forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
== :: Evt source tag -> Evt source tag -> Bool
$c== :: forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
Eq, Int -> Evt source tag -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
forall source tag.
(Show tag, Show source) =>
Int -> Evt source tag -> ShowS
forall source tag.
(Show tag, Show source) =>
[Evt source tag] -> ShowS
forall source tag.
(Show tag, Show source) =>
Evt source tag -> FilePath
showList :: [Evt source tag] -> ShowS
$cshowList :: forall source tag.
(Show tag, Show source) =>
[Evt source tag] -> ShowS
show :: Evt source tag -> FilePath
$cshow :: forall source tag.
(Show tag, Show source) =>
Evt source tag -> FilePath
showsPrec :: Int -> Evt source tag -> ShowS
$cshowsPrec :: forall source tag.
(Show tag, Show source) =>
Int -> Evt source tag -> ShowS
Show)

data Cmd
  = Cmd_Remount
  deriving (Cmd -> Cmd -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cmd -> Cmd -> Bool
$c/= :: Cmd -> Cmd -> Bool
== :: Cmd -> Cmd -> Bool
$c== :: Cmd -> Cmd -> Bool
Eq, Int -> Cmd -> ShowS
[Cmd] -> ShowS
Cmd -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Cmd] -> ShowS
$cshowList :: [Cmd] -> ShowS
show :: Cmd -> FilePath
$cshow :: Cmd -> FilePath
showsPrec :: Int -> Cmd -> ShowS
$cshowsPrec :: Int -> Cmd -> ShowS
Show)

-- | Like `unionMount` but without exception interrupting or re-mounting.
unionMount' ::
  forall source tag m m1.
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLogger m,
    MonadLogger m1,
    MonadIO m1,
    Ord source,
    Ord tag
  ) =>
  Set (source, FilePath) ->
  [(tag, FilePattern)] ->
  [FilePattern] ->
  m1
    ( Change source tag,
      (Change source tag -> m ()) ->
      m Cmd
    )
unionMount' :: forall source tag (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLogger m1,
 MonadIO m1, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
unionMount' Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore = do
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall source. Ord source => OverlayFs source
emptyOverlayFs @source) forall a b. (a -> b) -> a -> b
$ do
    -- Initial traversal of sources
    Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
changes0 :: Change source tag <-
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (source, FilePath)
sources forall a b. (a -> b) -> a -> b
$ \(source
src, FilePath
folder) -> do
          [(tag, [FilePath])]
taggedFiles <- forall (m :: * -> *) b.
(MonadIO m, MonadLogger m, Ord b) =>
FilePath -> [(b, FilePath)] -> [FilePath] -> m [(b, [FilePath])]
filesMatchingWithTag FilePath
folder [(tag, FilePath)]
pats [FilePath]
ignore
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(tag, [FilePath])]
taggedFiles forall a b. (a -> b) -> a -> b
$ \(tag
tag, [FilePath]
fs) -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
fs forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
              forall s (m :: * -> *). MonadState s m => s -> m ()
put forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source tag (m :: * -> *).
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp (forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Existing ()) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
    OverlayFs source
ofs <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
changes0,
        \Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
-> m ()
reportChange -> do
          -- Run fsnotify on sources
          TMVar (source, FilePath, Either (FolderAction ()) (FileAction ()))
q :: TMVar (x, FilePath, Either (FolderAction ()) (FileAction ())) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (forall x (m :: * -> *).
(Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) =>
TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> [(x, FilePath)] -> m Cmd
onChange TMVar (source, FilePath, Either (FolderAction ()) (FileAction ()))
q (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (source, FilePath)
sources)) forall a b. (a -> b) -> a -> b
$
              let readDebounced :: StateT
  (OverlayFs source)
  m
  (source, FilePath, Either (FolderAction ()) (FileAction ()))
readDebounced = do
                    -- Wait for some initial action in the queue.
                    (source, FilePath, Either (FolderAction ()) (FileAction ()))
_ <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar TMVar (source, FilePath, Either (FolderAction ()) (FileAction ()))
q
                    -- 100ms is a reasonable wait period to gather (possibly related) events.
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
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)
                    forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT
  (OverlayFs source)
  m
  (source, FilePath, Either (FolderAction ()) (FileAction ()))
readDebounced forall (f :: * -> *) a. Applicative f => a -> f a
pure
                      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (source, FilePath, Either (FolderAction ()) (FileAction ()))
q)
                  loop :: StateT (OverlayFs source) m Cmd
loop = do
                    (source
src, FilePath
fp, Either (FolderAction ()) (FileAction ())
actE) <- StateT
  (OverlayFs source)
  m
  (source, FilePath, Either (FolderAction ()) (FileAction ()))
readDebounced
                    let shouldIgnore :: Bool
shouldIgnore = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
?== FilePath
fp) [FilePath]
ignore
                    case Either (FolderAction ()) (FileAction ())
actE of
                      Left FolderAction ()
_ -> do
                        let reason :: Text
reason = Text
"Unhandled folder event on '" forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
fp forall a. Semigroup a => a -> a -> a
<> Text
"'"
                        if Bool
shouldIgnore
                          then do
                            forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelWarn forall a b. (a -> b) -> a -> b
$ Text
reason forall a. Semigroup a => a -> a -> a
<> Text
" on an ignored path"
                            StateT (OverlayFs source) m Cmd
loop
                          else do
                            -- We don't know yet how to deal with folder events. Just reboot the mount.
                            forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelWarn forall a b. (a -> b) -> a -> b
$ Text
reason forall a. Semigroup a => a -> a -> a
<> Text
"; suggesting a re-mount"
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure Cmd
Cmd_Remount -- Exit, asking user to remokunt
                      Right FileAction ()
act -> do
                        case forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
shouldIgnore) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall b. [(b, FilePath)] -> FilePath -> Maybe b
getTag [(tag, FilePath)]
pats FilePath
fp of
                          Maybe tag
Nothing -> StateT (OverlayFs source) m Cmd
loop
                          Just tag
tag -> do
                            Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
changes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ do
                              forall s (m :: * -> *). MonadState s m => s -> m ()
put forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source tag (m :: * -> *).
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp FileAction ()
act forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
                            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
-> m ()
reportChange Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
changes
                            StateT (OverlayFs source) m Cmd
loop
               in forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (OverlayFs source) m Cmd
loop OverlayFs source
ofs
      )

filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath]
filesMatching :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
FilePath -> [FilePath] -> [FilePath] -> m [FilePath]
filesMatching FilePath
parent' [FilePath]
pats [FilePath]
ignore = do
  FilePath
parent <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
parent'
  forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ FilePath
"Traversing " forall a. Semigroup a => a -> a -> a
<> FilePath
parent forall a. Semigroup a => a -> a -> a
<> FilePath
" for files matching " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [FilePath]
pats forall a. Semigroup a => a -> a -> a
<> FilePath
", ignoring " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show [FilePath]
ignore
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> [FilePath] -> IO [FilePath]
getDirectoryFilesIgnore FilePath
parent [FilePath]
pats [FilePath]
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 :: forall (m :: * -> *) b.
(MonadIO m, MonadLogger m, Ord b) =>
FilePath -> [(b, FilePath)] -> [FilePath] -> m [(b, [FilePath])]
filesMatchingWithTag FilePath
parent' [(b, FilePath)]
pats [FilePath]
ignore = do
  [FilePath]
fs <- forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
FilePath -> [FilePath] -> [FilePath] -> m [FilePath]
filesMatching FilePath
parent' (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(b, FilePath)]
pats) [FilePath]
ignore
  let m :: Map b [FilePath]
m = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [FilePath]
fs forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
          b
tag <- forall b. [(b, FilePath)] -> FilePath -> Maybe b
getTag [(b, FilePath)]
pats FilePath
fp
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
tag, forall x. One x => OneItem x -> x
one FilePath
fp)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map b [FilePath]
m

getTag :: [(b, FilePattern)] -> FilePath -> Maybe b
getTag :: forall b. [(b, FilePath)] -> FilePath -> Maybe b
getTag [(b, FilePath)]
pats FilePath
fp =
  let pull :: [(a, FilePath)] -> Maybe a
pull [(a, FilePath)]
patterns =
        forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(a, FilePath)]
patterns forall a b. (a -> b) -> a -> b
$ \(a
tag, FilePath
pat) -> do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ FilePath
pat FilePath -> FilePath -> Bool
?== FilePath
fp
            forall (f :: * -> *) a. Applicative f => a -> f a
pure a
tag
   in if FilePath -> Bool
isRelative FilePath
fp
        then forall {a}. [(a, FilePath)] -> Maybe a
pull [(b, FilePath)]
pats
        else -- `fp` is an absolute path (because of use of symlinks), so let's
        -- be more lenient in matching it. Note that this does meat we might
        -- match files the user may not have originally intended. This is
        -- the trade offs with using symlinks.
          forall {a}. [(a, FilePath)] -> Maybe a
pull forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (FilePath
"**/" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(b, FilePath)]
pats

data RefreshAction
  = -- | No recent change. Just notifying of file's existance
    Existing
  | -- | New file got created
    New
  | -- | The already existing file was updated.
    Update
  deriving (RefreshAction -> RefreshAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RefreshAction -> RefreshAction -> Bool
$c/= :: RefreshAction -> RefreshAction -> Bool
== :: RefreshAction -> RefreshAction -> Bool
$c== :: RefreshAction -> RefreshAction -> Bool
Eq, Int -> RefreshAction -> ShowS
[RefreshAction] -> ShowS
RefreshAction -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RefreshAction] -> ShowS
$cshowList :: [RefreshAction] -> ShowS
show :: RefreshAction -> FilePath
$cshow :: RefreshAction -> FilePath
showsPrec :: Int -> RefreshAction -> ShowS
$cshowsPrec :: Int -> RefreshAction -> ShowS
Show)

data FileAction a
  = -- | A new file, or updated file, is available
    Refresh RefreshAction a
  | -- | The file just got deleted.
    Delete
  deriving (FileAction a -> FileAction a -> Bool
forall a. Eq a => FileAction a -> FileAction a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileAction a -> FileAction a -> Bool
$c/= :: forall a. Eq a => FileAction a -> FileAction a -> Bool
== :: FileAction a -> FileAction a -> Bool
$c== :: forall a. Eq a => FileAction a -> FileAction a -> Bool
Eq, Int -> FileAction a -> ShowS
forall a. Show a => Int -> FileAction a -> ShowS
forall a. Show a => [FileAction a] -> ShowS
forall a. Show a => FileAction a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileAction a] -> ShowS
$cshowList :: forall a. Show a => [FileAction a] -> ShowS
show :: FileAction a -> FilePath
$cshow :: forall a. Show a => FileAction a -> FilePath
showsPrec :: Int -> FileAction a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FileAction a -> ShowS
Show, forall a b. a -> FileAction b -> FileAction a
forall a b. (a -> b) -> FileAction a -> FileAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FileAction b -> FileAction a
$c<$ :: forall a b. a -> FileAction b -> FileAction a
fmap :: forall a b. (a -> b) -> FileAction a -> FileAction b
$cfmap :: forall a b. (a -> b) -> FileAction a -> FileAction b
Functor)

-- | This is not an action on file, rather an action on a directory (which
-- may contain files, which would be outside the scope of this fsnotify event,
-- and so the user must manually deal with them.)
newtype FolderAction a = FolderAction a
  deriving (FolderAction a -> FolderAction a -> Bool
forall a. Eq a => FolderAction a -> FolderAction a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FolderAction a -> FolderAction a -> Bool
$c/= :: forall a. Eq a => FolderAction a -> FolderAction a -> Bool
== :: FolderAction a -> FolderAction a -> Bool
$c== :: forall a. Eq a => FolderAction a -> FolderAction a -> Bool
Eq, Int -> FolderAction a -> ShowS
forall a. Show a => Int -> FolderAction a -> ShowS
forall a. Show a => [FolderAction a] -> ShowS
forall a. Show a => FolderAction a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FolderAction a] -> ShowS
$cshowList :: forall a. Show a => [FolderAction a] -> ShowS
show :: FolderAction a -> FilePath
$cshow :: forall a. Show a => FolderAction a -> FilePath
showsPrec :: Int -> FolderAction a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FolderAction a -> ShowS
Show, forall a b. a -> FolderAction b -> FolderAction a
forall a b. (a -> b) -> FolderAction a -> FolderAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FolderAction b -> FolderAction a
$c<$ :: forall a b. a -> FolderAction b -> FolderAction a
fmap :: forall a b. (a -> b) -> FolderAction a -> FolderAction b
$cfmap :: forall a b. (a -> b) -> FolderAction a -> FolderAction b
Functor)

refreshAction :: FileAction a -> Maybe RefreshAction
refreshAction :: forall a. FileAction a -> Maybe RefreshAction
refreshAction = \case
  Refresh RefreshAction
act a
_ -> forall a. a -> Maybe a
Just RefreshAction
act
  FileAction a
_ -> forall a. Maybe a
Nothing

onChange ::
  forall x m.
  (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 :: forall x (m :: * -> *).
(Eq x, MonadIO m, MonadLogger m, MonadUnliftIO m) =>
TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> [(x, FilePath)] -> m Cmd
onChange TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
q [(x, FilePath)]
roots = do
  forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m) =>
(WatchManager -> m a) -> m a
withManagerM forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
    [IO ()]
stops <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(x, FilePath)]
roots forall a b. (a -> b) -> a -> b
$ \(x
x, FilePath
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
      -- @parent'@ (as passed by user), which is what @f@ will expect.
      FilePath
root <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
rootRel
      forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ FilePath
"Monitoring " forall a. Semigroup a => a -> a -> a
<> FilePath
root forall a. Semigroup a => a -> a -> a
<> FilePath
" for changes"
      forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
WatchManager
-> FilePath -> ActionPredicate -> (Event -> m ()) -> m (IO ())
watchTreeM WatchManager
mgr FilePath
root (forall a b. a -> b -> a
const Bool
True) forall a b. (a -> b) -> a -> b
$ \Event
event -> do
        forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelDebug forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show Event
event
        forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
          Maybe (x, FilePath, Either (FolderAction ()) (FileAction ()))
lastQ <- forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
q
          let fp :: FilePath
fp = FilePath -> ShowS
makeRelative FilePath
root forall a b. (a -> b) -> a -> b
$ Event -> FilePath
eventPath Event
event
              f :: Either (FolderAction ()) (FileAction ()) -> STM ()
f Either (FolderAction ()) (FileAction ())
act = forall a. TMVar a -> a -> STM ()
putTMVar TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
q (x
x, FilePath
fp, Either (FolderAction ()) (FileAction ())
act)
              -- Re-add last item to the queue
              reAddQ :: STM ()
reAddQ = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (x, FilePath, Either (FolderAction ()) (FileAction ()))
lastQ (forall a. TMVar a -> a -> STM ()
putTMVar TMVar (x, FilePath, Either (FolderAction ()) (FileAction ()))
q)
          if Event -> EventIsDirectory
eventIsDirectory Event
event forall a. Eq a => a -> a -> Bool
== EventIsDirectory
IsDirectory
            then Either (FolderAction ()) (FileAction ()) -> STM ()
f forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> FolderAction a
FolderAction ()
            else do
              let newAction :: Maybe (FileAction ())
newAction = case Event
event of
                    Added {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
New ()
                    Modified {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Update ()
                    ModifiedAttributes {} -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Update ()
                    Removed {} -> forall a. a -> Maybe a
Just forall a. FileAction a
Delete
                    Event
_ -> forall a. Maybe a
Nothing
              -- Merge with the last action when it makes sense to do so.
              case (Maybe (x, FilePath, Either (FolderAction ()) (FileAction ()))
lastQ, Maybe (FileAction ())
newAction) of
                (Maybe (x, FilePath, Either (FolderAction ()) (FileAction ()))
_, Maybe (FileAction ())
Nothing) -> STM ()
reAddQ
                (Just (x
lastTag, FilePath
lastFp, Right FileAction ()
lastAction), Just FileAction ()
a)
                  | x
lastTag forall a. Eq a => a -> a -> Bool
== x
x Bool -> Bool -> Bool
&& FilePath
lastFp forall a. Eq a => a -> a -> Bool
== FilePath
fp ->
                      case (FileAction ()
lastAction, FileAction ()
a) of
                        (FileAction ()
Delete, Refresh RefreshAction
New ()) -> Either (FolderAction ()) (FileAction ()) -> STM ()
f forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Update ()
                        (Refresh RefreshAction
New (), Refresh RefreshAction
Update ()) -> Either (FolderAction ()) (FileAction ()) -> STM ()
f forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
New ()
                        (Refresh RefreshAction
New (), FileAction ()
Delete) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        (FileAction (), FileAction ())
_ -> Either (FolderAction ()) (FileAction ()) -> STM ()
f forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right FileAction ()
a
                (Maybe (x, FilePath, Either (FolderAction ()) (FileAction ()))
_, Just FileAction ()
a) -> STM ()
reAddQ forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either (FolderAction ()) (FileAction ()) -> STM ()
f (forall a b. b -> Either a b
Right FileAction ()
a)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound)
      forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` do
        forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo Text
"Stopping fsnotify monitor."
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IO ()]
stops forall a. a -> a
id
    -- Unreachable
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Cmd
Cmd_Remount

withManagerM ::
  (MonadIO m, MonadUnliftIO m) =>
  (WatchManager -> m a) ->
  m a
withManagerM :: forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m) =>
(WatchManager -> m a) -> m a
withManagerM WatchManager -> m a
f = do
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
defaultConfig forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> forall a. m a -> IO a
run (WatchManager -> m a
f WatchManager
mgr)

watchTreeM ::
  forall m.
  (MonadIO m, MonadUnliftIO m) =>
  WatchManager ->
  FilePath ->
  ActionPredicate ->
  (Event -> m ()) ->
  m StopListening
watchTreeM :: forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
WatchManager
-> FilePath -> ActionPredicate -> (Event -> m ()) -> m (IO ())
watchTreeM WatchManager
wm FilePath
fp ActionPredicate
pr Event -> m ()
f =
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchTree WatchManager
wm FilePath
fp ActionPredicate
pr forall a b. (a -> b) -> a -> b
$ \Event
evt -> forall a. m a -> IO a
run (Event -> m ()
f Event
evt)

log :: MonadLogger m => LogLevel -> Text -> m ()
log :: forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log = forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc Text
"System.UnionMount"

-- TODO: Abstract in module with StateT / MonadState
newtype OverlayFs source = OverlayFs (Map FilePath (Set source))

-- TODO: Replace this with a function taking `NonEmpty source`
emptyOverlayFs :: Ord source => OverlayFs source
emptyOverlayFs :: forall source. Ord source => OverlayFs source
emptyOverlayFs = forall source. Map FilePath (Set source) -> OverlayFs source
OverlayFs forall a. Monoid a => a
mempty

overlayFsModify :: FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify :: forall src.
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
k Set src -> Set src
f (OverlayFs Map FilePath (Set src)
m) =
  forall source. Map FilePath (Set source) -> OverlayFs source
OverlayFs forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
k (Set src -> Set src
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
k Map FilePath (Set src)
m) Map FilePath (Set src)
m

overlayFsAdd :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd :: forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd FilePath
fp src
src =
  forall src.
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
fp forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert src
src

overlayFsRemove :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove :: forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove FilePath
fp src
src =
  forall src.
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
fp forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.delete src
src

overlayFsLookup :: FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup :: forall source.
FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup FilePath
fp (OverlayFs Map FilePath (Set source)
m) = do
  NonEmpty source
sources <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fp Map FilePath (Set source)
m
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty source
sources forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,FilePath
fp)

-- Files matched by each tag pattern, each represented by their corresponding
-- file (absolute path) in the individual sources. It is up to the user to union
-- them (for now).
type Change source tag = Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))

-- | Report a change to overlay fs
changeInsert ::
  (Ord source, Ord tag, MonadState (OverlayFs source) m) =>
  source ->
  tag ->
  FilePath ->
  FileAction () ->
  Change source tag ->
  m (Change source tag)
changeInsert :: forall source tag (m :: * -> *).
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp FileAction ()
act Change source tag
ch = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Change source tag
ch forall a b. (a -> b) -> a -> b
$ do
    -- First, register this change in the overlayFs
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$
        (if FileAction ()
act forall a. Eq a => a -> a -> Bool
== forall a. FileAction a
Delete then forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove else forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd)
          FilePath
fp
          source
src
    FileAction (NonEmpty (source, FilePath))
overlays <-
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall source.
FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup FilePath
fp) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Maybe (NonEmpty (source, FilePath))
Nothing -> forall a. FileAction a
Delete
        Just NonEmpty (source, FilePath)
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 :: RefreshAction
combinedAction = forall a. a -> Maybe a -> a
fromMaybe RefreshAction
Existing forall a b. (a -> b) -> a -> b
$ forall a. FileAction a -> Maybe RefreshAction
refreshAction FileAction ()
act
           in forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
combinedAction NonEmpty (source, FilePath)
fs
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup tag
tag) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath))))
Nothing ->
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton FilePath
fp FileAction (NonEmpty (source, FilePath))
overlays
      Just Map FilePath (FileAction (NonEmpty (source, FilePath)))
files ->
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
fp FileAction (NonEmpty (source, FilePath))
overlays Map FilePath (FileAction (NonEmpty (source, FilePath)))
files