diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Add.hs | 7 | ||||
| -rw-r--r-- | Command/Watch.hs | 136 |
2 files changed, 84 insertions, 59 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 3f39f8713..ccdff67ec 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -94,9 +94,8 @@ undo file key e = do src <- inRepo $ gitAnnexLocation key liftIO $ moveFile src file -{- Creates the symlink to the annexed content, and also returns the link's - - text. -} -link :: FilePath -> Key -> Bool -> Annex FilePath +{- Creates the symlink to the annexed content. -} +link :: FilePath -> Key -> Bool -> Annex () link file key hascontent = handle (undo file key) $ do l <- calcGitLink file key liftIO $ createSymbolicLink l file @@ -110,8 +109,6 @@ link file key hascontent = handle (undo file key) $ do mtime <- modificationTime <$> getFileStatus file touch file (TimeSpec mtime) False - return l - {- Note: Several other commands call this, and expect it to - create the symlink and add it. -} cleanup :: FilePath -> Key -> Bool -> CommandCleanup diff --git a/Command/Watch.hs b/Command/Watch.hs index f468d7271..ab0c0ce79 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -30,7 +30,16 @@ import Utility.Inotify import System.INotify #endif -type ChangeChan = TChan UTCTime +type ChangeChan = TChan Change + +type Handler = FilePath -> Annex (Maybe Change) + +data Change = Change + { changeTime :: UTCTime + , changeFile :: FilePath + , changeDesc :: String + } + deriving (Show) def :: [Command] def = [command "watch" paramPaths seek "watch for changes"] @@ -52,7 +61,7 @@ watch = do withStateMVar $ \st -> liftIO $ withINotify $ \i -> do changechan <- atomically newTChan _ <- forkIO $ commitThread st changechan - let hook a = Just $ runHook st changechan a + let hook a = Just $ runHandler st changechan a let hooks = WatchHooks { addHook = hook onAdd , delHook = hook onDel @@ -94,56 +103,70 @@ runStateMVar mvar a = do !newstate <- Annex.exec startstate a putMVar mvar newstate -{- Runs a hook, inside the Annex monad. +{- Runs an action handler, inside the Annex monad. - - Exceptions are ignored, otherwise a whole watcher thread could be crashed. -} -runHook :: MVar Annex.AnnexState -> ChangeChan -> (FilePath -> Annex ()) -> FilePath -> IO () -runHook st changetimes a f = handle =<< tryIO (runStateMVar st go) +runHandler :: MVar Annex.AnnexState -> ChangeChan -> Handler -> FilePath -> IO () +runHandler st changechan hook file = handle =<< tryIO (runStateMVar st go) where - go = do - a f - signalChange changetimes + go = maybe noop (signalChange changechan) =<< hook file handle (Right ()) = return () handle (Left e) = putStrLn $ show e +{- Handlers call this when they made a change that needs to get committed. -} +madeChange :: FilePath -> String -> Annex (Maybe Change) +madeChange file desc = liftIO $ + Just <$> (Change <$> getCurrentTime <*> pure file <*> pure desc) + {- Adding a file is tricky; the file has to be replaced with a symlink - but this is race prone, as the symlink could be changed immediately - after creation. To avoid that race, git add is not used to stage the - - symlink. -} -onAdd :: FilePath -> Annex () + - symlink. + - + - Inotify will notice the new symlink, so this Handler does not stage it + - or return a Change, leaving that to onAddSymlink. + -} +onAdd :: Handler onAdd file = do showStart "add" file - Command.Add.ingest file >>= go + handle =<< Command.Add.ingest file + return Nothing where - go Nothing = showEndFail - go (Just key) = do - link <- Command.Add.link file key True - stageSymlink file link + handle Nothing = showEndFail + handle (Just key) = do + Command.Add.link file key True showEndOk {- A symlink might be an arbitrary symlink, which is just added. - Or, if it is a git-annex symlink, ensure it points to the content - before adding it. -} -onAddSymlink :: FilePath -> Annex () +onAddSymlink :: Handler onAddSymlink file = go =<< Backend.lookupFile file where - go Nothing = addlink =<< liftIO (readSymbolicLink file) + go Nothing = do + addlink =<< liftIO (readSymbolicLink file) + madeChange file "add" go (Just (key, _)) = do link <- calcGitLink file key ifM ((==) link <$> liftIO (readSymbolicLink file)) - ( addlink link + ( do + addlink link + madeChange file "add" , do liftIO $ removeFile file liftIO $ createSymbolicLink link file addlink link + madeChange file "fix" ) addlink link = stageSymlink file link -onDel :: FilePath -> Annex () -onDel file = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.unstageFile file) +onDel :: Handler +onDel file = do + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.unstageFile file) + madeChange file "rm" {- A directory has been deleted, or moved, so tell git to remove anything - that was inside it from its cache. Since it could reappear at any time, @@ -152,13 +175,17 @@ onDel file = Annex.Queue.addUpdateIndex =<< - Note: This could use unstageFile, but would need to run another git - command to get the recursive list of files in the directory, so rm is - just as good. -} -onDelDir :: FilePath -> Annex () -onDelDir dir = Annex.Queue.addCommand "rm" - [Params "--quiet -r --cached --ignore-unmatch --"] [dir] +onDelDir :: Handler +onDelDir dir = do + Annex.Queue.addCommand "rm" + [Params "--quiet -r --cached --ignore-unmatch --"] [dir] + madeChange dir "rmdir" {- Called when there's an error with inotify. -} -onErr :: String -> Annex () -onErr = warning +onErr :: Handler +onErr msg = do + warning msg + return Nothing {- Adds a symlink to the index, without ever accessing the actual symlink - on disk. -} @@ -168,16 +195,17 @@ stageSymlink file linktext = inRepo (Git.UpdateIndex.stageSymlink file linktext) {- Signals that a change has been made, that needs to get committed. -} -signalChange :: ChangeChan -> Annex () -signalChange chan = do - liftIO $ (atomically . writeTChan chan) =<< getCurrentTime +signalChange :: ChangeChan -> Change -> Annex () +signalChange chan change = do + liftIO $ atomically $ writeTChan chan change + -- Just in case the commit thread is not flushing -- the queue fast enough. Annex.Queue.flushWhenFull -{- Gets the times of all unhandled changes. +{- Gets all unhandled changes. - Blocks until at least one change is made. -} -getChanges :: ChangeChan -> IO [UTCTime] +getChanges :: ChangeChan -> IO [Change] getChanges chan = atomically $ do c <- readTChan chan go [c] @@ -190,10 +218,10 @@ getChanges chan = atomically $ do {- Puts unhandled changes back into the channel. - Note: Original order is not preserved. -} -refillChanges :: ChangeChan -> [UTCTime] -> IO () +refillChanges :: ChangeChan -> [Change] -> IO () refillChanges chan cs = atomically $ mapM_ (writeTChan chan) cs -{- This thread makes git commits. -} +{- This thread makes git commits at appropriate times. -} commitThread :: MVar Annex.AnnexState -> ChangeChan -> IO () commitThread st changechan = forever $ do -- First, a simple rate limiter. @@ -203,38 +231,38 @@ commitThread st changechan = forever $ do -- Now see if now's a good time to commit. time <- getCurrentTime if shouldCommit time cs - then commit + then void $ tryIO $ runStateMVar st $ commitStaged else refillChanges changechan cs where - commit = void $ tryIO $ runStateMVar st $ do - Annex.Queue.flush - inRepo $ Git.Command.run "commit" - [ Param "--allow-empty-message" - , Param "-m", Param "" - -- Empty commits may be made if tree - -- changes cancel each other out, etc - , Param "--allow-empty" - -- Avoid running the usual git-annex - -- pre-commit hook; watch does the same - -- symlink fixing, and we don't want to - -- deal with unlocked files in these - -- commits. - , Param "--quiet" - ] oneSecond = 1000000 -- microseconds +commitStaged :: Annex () +commitStaged = do + Annex.Queue.flush + inRepo $ Git.Command.run "commit" + [ Param "--allow-empty-message" + , Param "-m", Param "" + -- Empty commits may be made if tree changes cancel + -- each other out, etc + , Param "--allow-empty" + -- Avoid running the usual git-annex pre-commit hook; + -- watch does the same symlink fixing, and we don't want + -- to deal with unlocked files in these commits. + , Param "--quiet" + ] + {- Decide if now is a good time to make a commit. - Note that the list of change times has an undefined order. - - Current strategy: If there have been 10 commits within the past second, - a batch activity is taking place, so wait for later. -} -shouldCommit :: UTCTime -> [UTCTime] -> Bool -shouldCommit now changetimes +shouldCommit :: UTCTime -> [Change] -> Bool +shouldCommit now changes | len == 0 = False | len > 4096 = True -- avoid bloating queue too much - | length (filter thisSecond changetimes) < 10 = True + | length (filter thisSecond changes) < 10 = True | otherwise = False -- batch activity where - len = length changetimes - thisSecond t = now `diffUTCTime` t <= 1 + len = length changes + thisSecond c = now `diffUTCTime` changeTime c <= 1 |