summaryrefslogtreecommitdiff
path: root/Command
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-06-10 18:29:05 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-06-10 18:41:05 -0400
commitaae0ba1995e258c4f4b83b40eb6324ec1f9baa05 (patch)
tree651b62523ad250cfed4f30edabd213f04da678b9 /Command
parentfc0dd7977490917a1a87968ba117799bf04891bd (diff)
fixed the double commits problem
Diffstat (limited to 'Command')
-rw-r--r--Command/Add.hs7
-rw-r--r--Command/Watch.hs136
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