diff options
| -rw-r--r-- | Annex.hs | 3 | ||||
| -rw-r--r-- | Annex/Branch.hs | 14 | ||||
| -rw-r--r-- | Annex/Content.hs | 2 | ||||
| -rw-r--r-- | Annex/Queue.hs | 25 | ||||
| -rw-r--r-- | Command/Add.hs | 58 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Fix.hs | 2 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Lock.hs | 2 | ||||
| -rw-r--r-- | Command/Watch.hs | 234 | ||||
| -rw-r--r-- | Git/FilePath.hs | 34 | ||||
| -rw-r--r-- | Git/HashObject.hs | 4 | ||||
| -rw-r--r-- | Git/Queue.hs | 107 | ||||
| -rw-r--r-- | Git/Types.hs | 8 | ||||
| -rw-r--r-- | Git/UnionMerge.hs | 49 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 54 | ||||
| -rw-r--r-- | GitAnnex.hs | 2 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 8 | ||||
| -rw-r--r-- | Utility/Directory.hs | 7 | ||||
| -rw-r--r-- | Utility/Inotify.hs | 199 | ||||
| -rw-r--r-- | Utility/ThreadLock.hs | 35 | ||||
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | debian/control | 2 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 7 | ||||
| -rw-r--r-- | doc/install.mdwn | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 6 | ||||
| -rw-r--r-- | git-union-merge.hs | 2 |
28 files changed, 705 insertions, 169 deletions
@@ -14,6 +14,7 @@ module Annex ( newState, run, eval, + exec, getState, changeState, setFlag, @@ -134,6 +135,8 @@ run :: AnnexState -> Annex a -> IO (a, AnnexState) run s a = runStateT (runAnnex a) s eval :: AnnexState -> Annex a -> IO a eval s a = evalStateT (runAnnex a) s +exec :: AnnexState -> Annex a -> IO AnnexState +exec s a = execStateT (runAnnex a) s {- Sets a flag to True -} setFlag :: String -> Annex () diff --git a/Annex/Branch.hs b/Annex/Branch.hs index c8d0719b0..7b433cc6e 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -35,6 +35,8 @@ import qualified Git.Branch import qualified Git.UnionMerge import qualified Git.UpdateIndex import Git.HashObject +import Git.Types +import Git.FilePath import qualified Git.Index import Annex.CatFile import Annex.Perms @@ -259,15 +261,15 @@ files = withIndexUpdate $ do - in changes from other branches. -} genIndex :: Git.Repo -> IO () -genIndex g = Git.UpdateIndex.stream_update_index g - [Git.UpdateIndex.ls_tree fullname g] +genIndex g = Git.UpdateIndex.streamUpdateIndex g + [Git.UpdateIndex.lsTree fullname g] {- Merges the specified refs into the index. - Any changes staged in the index will be preserved. -} mergeIndex :: [Git.Ref] -> Annex () mergeIndex branches = do h <- catFileHandle - inRepo $ \g -> Git.UnionMerge.merge_index h g branches + inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a @@ -336,13 +338,13 @@ stageJournal = do g <- gitRepo withIndex $ liftIO $ do h <- hashObjectStart g - Git.UpdateIndex.stream_update_index g + Git.UpdateIndex.streamUpdateIndex g [genstream (gitAnnexJournalDir g) h fs] hashObjectStop h where genstream dir h fs streamer = forM_ fs $ \file -> do let path = dir </> file sha <- hashFile h path - _ <- streamer $ Git.UpdateIndex.update_index_line - sha (fileJournal file) + _ <- streamer $ Git.UpdateIndex.updateIndexLine + sha FileBlob (asTopFilePath $ fileJournal file) removeFile path diff --git a/Annex/Content.hs b/Annex/Content.hs index 26b332e24..232b43b2c 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -168,7 +168,7 @@ withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp - liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp + liftIO $ nukeFile tmp return res {- Checks that there is disk space available to store a given key, diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 24575e906..c019aed6c 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -1,26 +1,35 @@ {- git-annex command queue - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011, 2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} module Annex.Queue ( - add, + addCommand, + addUpdateIndex, flush, - flushWhenFull + flushWhenFull, + size ) where import Common.Annex import Annex hiding (new) import qualified Git.Queue +import qualified Git.UpdateIndex import Config {- Adds a git command to the queue. -} -add :: String -> [CommandParam] -> [FilePath] -> Annex () -add command params files = do +addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () +addCommand command params files = do q <- get - store $ Git.Queue.add q command params files + store =<< inRepo (Git.Queue.addCommand command params files q) + +{- Adds an update-index stream to the queue. -} +addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () +addUpdateIndex streamer = do + q <- get + store =<< inRepo (Git.Queue.addUpdateIndex streamer q) {- Runs the queue if it is full. Should be called periodically. -} flushWhenFull :: Annex () @@ -37,6 +46,10 @@ flush = do q' <- inRepo $ Git.Queue.flush q store q' +{- Gets the size of the queue. -} +size :: Annex Int +size = Git.Queue.size <$> get + get :: Annex Git.Queue.Queue get = maybe new return =<< getState repoqueue diff --git a/Command/Add.hs b/Command/Add.hs index 2c671eea2..3f39f8713 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -50,34 +50,40 @@ start file = notBareRepo $ ifAnnexed file fixup add - to prevent it from being modified in between. It's hard linked into a - temporary location, and its writable bits are removed. It could still be - written to by a process that already has it open for writing. -} -perform :: FilePath -> CommandPerform -perform file = do +lockDown :: FilePath -> Annex FilePath +lockDown file = do liftIO $ preventWrite file tmp <- fromRepo gitAnnexTmpDir createAnnexDirectory tmp pid <- liftIO getProcessID let tmpfile = tmp </> "add" ++ show pid ++ "." ++ takeFileName file - nuke tmpfile + liftIO $ nukeFile tmpfile liftIO $ createLink file tmpfile + return tmpfile + +{- Moves the file into the annex. -} +ingest :: FilePath -> Annex (Maybe Key) +ingest file = do + tmpfile <- lockDown file let source = KeySource { keyFilename = file, contentLocation = tmpfile } backend <- chooseBackend file genKey source backend >>= go tmpfile where - go _ Nothing = stop + go _ Nothing = return Nothing go tmpfile (Just (key, _)) = do handle (undo file key) $ moveAnnex key tmpfile - nuke file - next $ cleanup file key True + liftIO $ nukeFile file + return $ Just key -nuke :: FilePath -> Annex () -nuke file = liftIO $ whenM (doesFileExist file) $ removeFile file +perform :: FilePath -> CommandPerform +perform file = maybe stop (\key -> next $ cleanup file key True) =<< ingest file {- On error, put the file back so it doesn't seem to have vanished. - This can be called before or after the symlink is in place. -} undo :: FilePath -> Key -> IOException -> Annex a undo file key e = do whenM (inAnnex key) $ do - nuke file + liftIO $ nukeFile file handle tryharder $ fromAnnex key file logStatus key InfoMissing throw e @@ -88,24 +94,32 @@ undo file key e = do src <- inRepo $ gitAnnexLocation key liftIO $ moveFile src file -cleanup :: FilePath -> Key -> Bool -> CommandCleanup -cleanup file key hascontent = do - handle (undo file key) $ do - link <- calcGitLink file key - liftIO $ createSymbolicLink link file +{- Creates the symlink to the annexed content, and also returns the link's + - text. -} +link :: FilePath -> Key -> Bool -> Annex FilePath +link file key hascontent = handle (undo file key) $ do + l <- calcGitLink file key + liftIO $ createSymbolicLink l file - when hascontent $ do - logStatus key InfoPresent + when hascontent $ do + logStatus key InfoPresent - -- touch the symlink to have the same mtime as the - -- file it points to - liftIO $ do - mtime <- modificationTime <$> getFileStatus file - touch file (TimeSpec mtime) False + -- touch the symlink to have the same mtime as the + -- file it points to + liftIO $ 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 +cleanup file key hascontent = do + _ <- link file key hascontent params <- ifM (Annex.getState Annex.force) ( return [Param "-f"] , return [] ) - Annex.Queue.add "add" (params++[Param "--"]) [file] + Annex.Queue.addCommand "add" (params++[Param "--"]) [file] return True diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index a94c2873d..597a4eec0 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -40,5 +40,5 @@ perform key = maybe droplocal dropremote =<< Remote.byName =<< from performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - liftIO $ whenM (doesFileExist f) $ removeFile f + liftIO $ nukeFile f next $ return True diff --git a/Command/Fix.hs b/Command/Fix.hs index c4f981381..227e08cd2 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -36,5 +36,5 @@ perform file link = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs index ec194e06e..f7841c977 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -39,5 +39,5 @@ perform key file = do cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--"] [file] return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs index ae21acf8a..1fc656207 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -155,7 +155,7 @@ fixLink key file = do liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file liftIO $ createSymbolicLink want file - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True {- Checks that the location log reflects the current status of the key, diff --git a/Command/Lock.hs b/Command/Lock.hs index ab97b14bc..8aadf3f59 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -24,5 +24,5 @@ start file = do perform :: FilePath -> CommandPerform perform file = do - Annex.Queue.add "checkout" [Param "--"] [file] + Annex.Queue.addCommand "checkout" [Param "--"] [file] next $ return True -- no cleanup needed diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..34282e46c --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,234 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module Command.Watch where + +import Common.Annex +import Command +import Utility.ThreadLock +import qualified Annex +import qualified Annex.Queue +import qualified Command.Add +import qualified Git.Command +import qualified Git.UpdateIndex +import qualified Backend +import Annex.Content + +import Control.Concurrent +import Control.Concurrent.STM +import Data.Time.Clock + +#if defined linux_HOST_OS +import Utility.Inotify +import System.INotify +#endif + +type ChangeChan = TChan UTCTime + +def :: [Command] +def = [command "watch" paramPaths seek "watch for changes"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +#if defined linux_HOST_OS +start = notBareRepo $ do + showStart "watch" "." + showAction "scanning" + inRepo $ Git.Command.run "add" [Param "--update"] + next $ next $ withStateMVar $ \st -> liftIO $ withINotify $ \i -> do + changechan <- atomically newTChan + _ <- forkIO $ commitThread st changechan + let hook a = Just $ runHook st changechan a + let hooks = WatchHooks + { addHook = hook onAdd + , delHook = hook onDel + , addSymlinkHook = hook onAddSymlink + , delDirHook = hook onDelDir + , errHook = hook onErr + } + watchDir i "." (ignored . takeFileName) hooks + putStrLn "(started)" + waitForTermination + return True +#else +start = error "watch mode is so far only available on Linux" +#endif + +ignored :: FilePath -> Bool +ignored ".git" = True +ignored ".gitignore" = True +ignored ".gitattributes" = True +ignored _ = False + +{- Stores the Annex state in a MVar, so that threaded actions can access + - it. + - + - Once the action is finished, retrieves the state from the MVar. + -} +withStateMVar :: (MVar Annex.AnnexState -> Annex a) -> Annex a +withStateMVar a = do + state <- Annex.getState id + mvar <- liftIO $ newMVar state + r <- a mvar + newstate <- liftIO $ takeMVar mvar + Annex.changeState (const newstate) + return r + +{- Runs an Annex action, using the state from the MVar. -} +runStateMVar :: MVar Annex.AnnexState -> Annex () -> IO () +runStateMVar mvar a = do + startstate <- takeMVar mvar + !newstate <- Annex.exec startstate a + putMVar mvar newstate + +{- Runs a hook, 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) + where + go = do + a f + signalChange changetimes + handle (Right ()) = return () + handle (Left e) = putStrLn $ show e + +{- 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 () +onAdd file = do + showStart "add" file + Command.Add.ingest file >>= go + where + go Nothing = showEndFail + go (Just key) = do + link <- Command.Add.link file key True + stageSymlink file link + 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 file = go =<< Backend.lookupFile file + where + go Nothing = addlink =<< liftIO (readSymbolicLink file) + go (Just (key, _)) = do + link <- calcGitLink file key + ifM ((==) link <$> liftIO (readSymbolicLink file)) + ( addlink link + , do + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + addlink link + ) + addlink link = stageSymlink file link + +onDel :: FilePath -> Annex () +onDel file = Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.unstageFile file) + +{- 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, + - use --cached to only delete it from the index. + - + - 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] + +{- Called when there's an error with inotify. -} +onErr :: String -> Annex () +onErr = warning + +{- Adds a symlink to the index, without ever accessing the actual symlink + - on disk. -} +stageSymlink :: FilePath -> String -> Annex () +stageSymlink file linktext = + Annex.Queue.addUpdateIndex =<< + 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 + -- Just in case the commit thread is not flushing + -- the queue fast enough. + Annex.Queue.flushWhenFull + +{- Gets the times of all unhandled changes. + - Blocks until at least one change is made. -} +getChanges :: ChangeChan -> IO [UTCTime] +getChanges chan = atomically $ do + c <- readTChan chan + go [c] + where + go l = do + v <- tryReadTChan chan + case v of + Nothing -> return l + Just c -> go (c:l) + +{- Puts unhandled changes back into the channel. + - Note: Original order is not preserved. -} +refillChanges :: ChangeChan -> [UTCTime] -> IO () +refillChanges chan cs = atomically $ mapM_ (writeTChan chan) cs + +{- This thread makes git commits. -} +commitThread :: MVar Annex.AnnexState -> ChangeChan -> IO () +commitThread st changechan = forever $ do + -- First, a simple rate limiter. + threadDelay $ oneSecond + liftIO $ putStrLn "running" + -- Next, wait until at least one change has been made. + cs <- getChanges changechan + -- Now see if now's a good time to commit. + ifM (shouldCommit <$> getCurrentTime <*> pure cs) $ + ( commit + , do + liftIO $ putStrLn $ "no commit now " ++ show (length cs) + refillChanges changechan cs + ) + where + commit = void $ tryIO $ runStateMVar st $ do + Annex.Queue.flush + {- Empty commits may be made if tree + - changes cancel each other out, etc. -} + inRepo $ Git.Command.run "commit" + [ Param "--allow-empty-message" + , Param "-m", Param "" + , Param "--allow-empty" + , Param "--quiet" + ] + oneSecond = 1000000 -- microseconds + +{- 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 + | len == 0 = False + | len > 4096 = True -- avoid bloating queue too much + | length (filter thisSecond changetimes) < 10 = True + | otherwise = False -- batch activity + where + len = length changetimes + thisSecond t = now `diffUTCTime` t <= 1 diff --git a/Git/FilePath.hs b/Git/FilePath.hs new file mode 100644 index 000000000..6344353d6 --- /dev/null +++ b/Git/FilePath.hs @@ -0,0 +1,34 @@ +{- git FilePath library + - + - Different git commands use different types of FilePaths to refer to + - files in the repository. Some commands use paths relative to the + - top of the repository even when run in a subdirectory. Adding some + - types helps keep that straight. + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.FilePath ( + TopFilePath, + getTopFilePath, + toTopFilePath, + asTopFilePath, +) where + +import Common +import Git + +{- A FilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } + +{- The input FilePath can be absolute, or relative to the CWD. -} +toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath <$> + relPathDirToFile (repoPath repo) <$> absPath file + +{- The input FilePath must already be relative to the top of the git + - repository -} +asTopFilePath :: FilePath -> TopFilePath +asTopFilePath file = TopFilePath file diff --git a/Git/HashObject.hs b/Git/HashObject.hs index b052413fd..9f37de5ba 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -36,8 +36,8 @@ hashFile h file = CoProcess.query h send receive receive from = getSha "hash-object" $ hGetLine from {- Injects some content into git, returning its Sha. -} -hashObject :: Repo -> ObjectType -> String -> IO Sha -hashObject repo objtype content = getSha subcmd $ do +hashObject :: ObjectType -> String -> Repo -> IO Sha +hashObject objtype content repo = getSha subcmd $ do (h, s) <- pipeWriteRead (map Param params) content repo length s `seq` do forceSuccess h diff --git a/Git/Queue.hs b/Git/Queue.hs index b8055ab44..acf6cd091 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,7 +10,8 @@ module Git.Queue ( Queue, new, - add, + addCommand, + addUpdateIndex, size, full, flush, @@ -25,13 +26,31 @@ import Utility.SafeCommand import Common import Git import Git.Command +import qualified Git.UpdateIndex + +{- Queable actions that can be performed in a git repository. + -} +data Action + {- Updating the index file, using a list of streamers that can + - be added to as the queue grows. -} + = UpdateIndexAction + { getStreamers :: [Git.UpdateIndex.Streamer] + } + {- A git command to run, on a list of files that can be added to + - as the queue grows. -} + | CommandAction + { getSubcommand :: String + , getParams :: [CommandParam] + , getFiles :: [FilePath] + } + +{- A key that can uniquely represent an action in a Map. -} +data ActionKey = UpdateIndexActionKey | CommandActionKey String + deriving (Eq, Ord) -{- An action to perform in a git repository. The file to act on - - is not included, and must be able to be appended after the params. -} -data Action = Action - { getSubcommand :: String - , getParams :: [CommandParam] - } deriving (Show, Eq, Ord) +actionKey :: Action -> ActionKey +actionKey (UpdateIndexAction _) = UpdateIndexActionKey +actionKey CommandAction { getSubcommand = s } = CommandActionKey s {- A queue of actions to perform (in any order) on a git repository, - with lists of files to perform them on. This allows coalescing @@ -39,9 +58,8 @@ data Action = Action data Queue = Queue { size :: Int , _limit :: Int - , _items :: M.Map Action [FilePath] + , items :: M.Map ActionKey Action } - deriving (Show, Eq) {- A recommended maximum size for the queue, after which it should be - run. @@ -59,16 +77,57 @@ defaultLimit = 10240 new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. -} -add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue -add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m' +{- Adds an git command to the queue. + - + - Git commands with the same subcommand but different parameters are + - assumed to be equivilant enough to perform in any order with the same + - result. + -} +addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue +addCommand subcommand params files q repo = + updateQueue action different (length newfiles) q repo + where + key = actionKey action + action = CommandAction + { getSubcommand = subcommand + , getParams = params + , getFiles = newfiles + } + newfiles = files ++ maybe [] getFiles (M.lookup key $ items q) + + different (CommandAction { getSubcommand = s }) = s /= subcommand + different _ = True + +{- Adds an update-index streamer to the queue. -} +addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue +addUpdateIndex streamer q repo = + updateQueue action different 1 q repo + where + key = actionKey action + -- streamer is added to the end of the list, since + -- order does matter for update-index input + action = UpdateIndexAction $ streamers ++ [streamer] + streamers = maybe [] getStreamers $ M.lookup key $ items q + + different (UpdateIndexAction _) = False + different _ = True + +{- Updates or adds an action in the queue. If the queue already contains a + - different action, it will be flushed; this is to ensure that conflicting + - actions, like add and rm, are run in the right order.-} +updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue +updateQueue action different sizeincrease q repo + | null (filter different (M.elems (items q))) = return $ go q + | otherwise = go <$> flush q repo where - action = Action subcommand params - -- There are probably few items in the map, but there - -- can be a lot of files per item. So, optimise adding - -- files. - m' = M.insertWith' const action fs m - !fs = files ++ M.findWithDefault [] action m + go q' = newq + where + !newq = q' + { size = newsize + , items = newitems + } + !newsize = size q' + sizeincrease + !newitems = M.insertWith' const (actionKey action) action (items q') {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool @@ -77,7 +136,7 @@ full (Queue cur lim _) = cur > lim {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do - forM_ (M.toList m) $ uncurry $ runAction repo + forM_ (M.elems m) $ runAction repo return $ Queue 0 lim M.empty {- Runs an Action on a list of files in a git repository. @@ -86,12 +145,14 @@ flush (Queue _ lim m) repo = do - - Intentionally runs the command even if the list of files is empty; - this allows queueing commands that do not need a list of files. -} -runAction :: Repo -> Action -> [FilePath] -> IO () -runAction repo action files = +runAction :: Repo -> Action -> IO () +runAction repo (UpdateIndexAction streamers) = + Git.UpdateIndex.streamUpdateIndex repo streamers +runAction repo action@(CommandAction {}) = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs where params = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo feedxargs h = do fileEncoding h - hPutStr h $ join "\0" files + hPutStr h $ join "\0" $ getFiles action diff --git a/Git/Types.hs b/Git/Types.hs index 64d418a04..1df6e343b 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -63,3 +63,11 @@ readObjectType "commit" = Just CommitObject readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +{- Types of blobs. -} +data BlobType = FileBlob | ExecutableBlob | SymlinkBlob + +{- Git uses magic numbers to denote the type of a blob. -} +instance Show BlobType where + show FileBlob = "100644" + show ExecutableBlob = "100755" + show SymlinkBlob = "120000" diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs index 822e6abbf..0987f9131 100644 --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -7,7 +7,7 @@ module Git.UnionMerge ( merge, - merge_index + mergeIndex ) where import qualified Data.Text.Lazy as L @@ -22,6 +22,7 @@ import Git.Command import Git.UpdateIndex import Git.HashObject import Git.Types +import Git.FilePath {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -31,40 +32,40 @@ import Git.Types merge :: Ref -> Ref -> Repo -> IO () merge x y repo = do h <- catFileStart repo - stream_update_index repo - [ ls_tree x repo - , merge_trees x y h repo + streamUpdateIndex repo + [ lsTree x repo + , mergeTrees x y h repo ] catFileStop h -{- Merges a list of branches into the index. Previously staged changed in +{- Merges a list of branches into the index. Previously staged changes in - the index are preserved (and participate in the merge). -} -merge_index :: CatFileHandle -> Repo -> [Ref] -> IO () -merge_index h repo bs = - stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs +mergeIndex :: CatFileHandle -> Repo -> [Ref] -> IO () +mergeIndex h repo bs = + streamUpdateIndex repo $ map (\b -> mergeTreeIndex b h repo) bs {- For merging two trees. -} -merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer -merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y] +mergeTrees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer +mergeTrees (Ref x) (Ref y) h = doMerge h $ "diff-tree":diffOpts ++ [x, y] {- For merging a single tree into the index. -} -merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer -merge_tree_index (Ref x) h = calc_merge h $ - "diff-index" : diff_opts ++ ["--cached", x] +mergeTreeIndex :: Ref -> CatFileHandle -> Repo -> Streamer +mergeTreeIndex (Ref x) h = doMerge h $ + "diff-index" : diffOpts ++ ["--cached", x] -diff_opts :: [String] -diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"] +diffOpts :: [String] +diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] -{- Calculates how to perform a merge, using git to get a raw diff, - - and generating update-index input. -} -calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer -calc_merge ch differ repo streamer = gendiff >>= go +{- Streams update-index changes to perform a merge, + - using git to get a raw diff. -} +doMerge :: CatFileHandle -> [String] -> Repo -> Streamer +doMerge ch differ repo streamer = gendiff >>= go where gendiff = pipeNullSplit (map Param differ) repo go [] = noop go (info:file:rest) = mergeFile info file ch repo >>= maybe (go rest) (\l -> streamer l >> go rest) - go (_:[]) = error "calc_merge parse error" + go (_:[]) = error $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the @@ -73,13 +74,15 @@ mergeFile :: String -> FilePath -> CatFileHandle -> Repo -> IO (Maybe String) mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha - shas -> use =<< either return (hashObject repo BlobObject . unlines) =<< - calcMerge . zip shas <$> mapM getcontents shas + shas -> use + =<< either return (\s -> hashObject BlobObject (unlines s) repo) + =<< calcMerge . zip shas <$> mapM getcontents shas where [_colonmode, _bmode, asha, bsha, _status] = words info getcontents s = map L.unpack . L.lines . L.decodeUtf8 <$> catObject h s - use sha = return $ Just $ update_index_line sha file + use sha = return $ Just $ + updateIndexLine sha FileBlob $ asTopFilePath file {- Calculates a union merge between a list of refs, with contents. - diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 04bc4da5b..07057ed98 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -5,26 +5,39 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.UpdateIndex ( Streamer, - stream_update_index, - update_index_line, - ls_tree + pureStreamer, + streamUpdateIndex, + lsTree, + updateIndexLine, + unstageFile, + stageSymlink ) where import System.Cmd.Utils import Common import Git +import Git.Types import Git.Command +import Git.FilePath +import Git.HashObject +import Git.Sha {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () +{- A streamer with a precalculated value. -} +pureStreamer :: String -> Streamer +pureStreamer !s = \streamer -> streamer s + {- Streams content into update-index from a list of Streamers. -} -stream_update_index :: Repo -> [Streamer] -> IO () -stream_update_index repo as = do +streamUpdateIndex :: Repo -> [Streamer] -> IO () +streamUpdateIndex repo as = do (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) fileEncoding h forM_ as (stream h) @@ -37,13 +50,30 @@ stream_update_index repo as = do hPutStr h s hPutStr h "\0" +{- A streamer that adds the current tree for a ref. Useful for eg, copying + - and modifying branches. -} +lsTree :: Ref -> Repo -> Streamer +lsTree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -update_index_line :: Sha -> FilePath -> String -update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file +updateIndexLine :: Sha -> BlobType -> TopFilePath -> String +updateIndexLine sha filetype file = + show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file -{- Gets the current tree for a ref. -} -ls_tree :: Ref -> Repo -> Streamer -ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo - where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] +{- A streamer that removes a file from the index. -} +unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile file repo = do + p <- toTopFilePath file repo + return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p + +{- A streamer that adds a symlink to the index. -} +stageSymlink :: FilePath -> String -> Repo -> IO Streamer +stageSymlink file linktext repo = do + line <- updateIndexLine + <$> hashObject BlobObject linktext repo + <*> pure SymlinkBlob + <*> toTopFilePath file repo + return $ pureStreamer line diff --git a/GitAnnex.hs b/GitAnnex.hs index 149b37f93..a4c5eb849 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -58,6 +58,7 @@ import qualified Command.Import import qualified Command.Map import qualified Command.Upgrade import qualified Command.Version +import qualified Command.Watch cmds :: [Command] cmds = concat @@ -99,6 +100,7 @@ cmds = concat , Command.Map.def , Command.Upgrade.def , Command.Version.def + , Command.Watch.def ] options :: [Option] diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 280742f06..31c0210c0 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -94,7 +94,7 @@ updateSymlinks = do link <- calcGitLink f k liftIO $ removeFile f liftIO $ createSymbolicLink link f - Annex.Queue.add "add" [Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [f] moveLocationLogs :: Annex () moveLocationLogs = do @@ -121,9 +121,9 @@ moveLocationLogs = do old <- liftIO $ readLog1 f new <- liftIO $ readLog1 dest liftIO $ writeLog1 dest (old++new) - Annex.Queue.add "add" [Param "--"] [dest] - Annex.Queue.add "add" [Param "--"] [f] - Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [dest] + Annex.Queue.addCommand "add" [Param "--"] [f] + Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 5bfd49a9c..52f2396d7 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -88,6 +88,13 @@ moveFile src dest = tryIO (rename src dest) >>= onrename (Left _) -> return False (Right s) -> return $ isDirectory s +{- Removes a file, which may or may not exist. + - + - Note that an exception is thrown if the file exists but + - cannot be removed. -} +nukeFile :: FilePath -> IO () +nukeFile file = whenM (doesFileExist file) $ removeFile file + {- Runs an action in another directory. -} bracketCd :: FilePath -> IO a -> IO a bracketCd dir a = go =<< getCurrentDirectory diff --git a/Utility/Inotify.hs b/Utility/Inotify.hs index d41e997d6..7329b5122 100644 --- a/Utility/Inotify.hs +++ b/Utility/Inotify.hs @@ -1,27 +1,34 @@ -{-# LANGUAGE CPP #-} +{- higher-level inotify interface + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} module Utility.Inotify where import Common hiding (isDirectory) +import Utility.ThreadLock + import System.INotify import qualified System.Posix.Files as Files -import System.Posix.Terminal -import Control.Concurrent.MVar -import System.Posix.Signals - -demo :: IO () -demo = withINotify $ \i -> do - watchDir i (const True) (Just add) (Just del) "/home/joey/tmp/me" - putStrLn "started" - waitForTermination - where - add file = putStrLn $ "add " ++ file - del file = putStrLn $ "del " ++ file +import System.IO.Error +import Control.Exception (throw) + +type Hook a = Maybe (a -> IO ()) + +data WatchHooks = WatchHooks + { addHook :: Hook FilePath + , addSymlinkHook :: Hook FilePath + , delHook :: Hook FilePath + , delDirHook :: Hook FilePath + , errHook :: Hook String -- error message + } {- Watches for changes to files in a directory, and all its subdirectories - - that match a test, using inotify. This function returns after its initial - - setup is complete, leaving a thread running. Then callbacks are made for - - adding and deleting files. + - that are not ignored, using inotify. This function returns after + - its initial scan is complete, leaving a thread running. Callbacks are + - made for different events. - - Inotify is weak at recursive directory watching; the whole directory - tree must be walked and watches set explicitly for each subdirectory. @@ -37,59 +44,127 @@ demo = withINotify $ \i -> do - Note: Due to the race amelioration, multiple add events may occur - for the same file. - - - Note: Moving a file may involve deleting it from its old location and - - adding it to the new location. + - Note: Moving a file will cause events deleting it from its old location + - and adding it to the new location. - - Note: Modification of files is not detected, and it's assumed that when - - a file that was open for write is closed, it's done being written + - a file that was open for write is closed, it's finished being written - to, and can be added. - - Note: inotify has a limit to the number of watches allowed, - /proc/sys/fs/inotify/max_user_watches (default 8192). - - So This will fail if there are too many subdirectories. + - So this will fail if there are too many subdirectories. The + - errHook is called when this happens. -} -watchDir :: INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir i test add del dir = watchDir' False i test add del dir -watchDir' :: Bool -> INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir' scan i test add del dir = do - if test dir - then void $ do - _ <- addWatch i watchevents dir go - mapM walk =<< dirContents dir - else noop +watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> WatchHooks -> IO () +watchDir i dir ignored hooks + | ignored dir = noop + | otherwise = do + lock <- newLock + let handler event = withLock lock (void $ go event) + void (addWatch i watchevents dir handler) + `catchIO` failedaddwatch + withLock lock $ + mapM_ walk =<< filter (not . dirCruft) <$> + getDirectoryContents dir where - watchevents - | isJust add && isJust del = - [Create, MoveIn, MoveOut, Delete, CloseWrite] - | isJust add = [Create, MoveIn, CloseWrite] - | isJust del = [Create, MoveOut, Delete] - | otherwise = [Create] - - recurse = watchDir' scan i test add del - walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f) - ( recurse f - , when (scan && isJust add) $ fromJust add f - ) - - go (Created { isDirectory = False }) = noop - go (Created { filePath = subdir }) = Just recurse <@> subdir - go (Closed { maybeFilePath = Just f }) = add <@> f - go (MovedIn { isDirectory = False, filePath = f }) = add <@> f - go (MovedOut { isDirectory = False, filePath = f }) = del <@> f - go (Deleted { isDirectory = False, filePath = f }) = del <@> f + recurse d = watchDir i d ignored hooks + + -- Select only inotify events required by the enabled + -- hooks, but always include Create so new directories can + -- be walked. + watchevents = Create : addevents ++ delevents + addevents + | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] + | otherwise = [] + delevents + | hashook delHook || hashook delDirHook = [MoveOut, Delete] + | otherwise = [] + + walk f = unless (ignored f) $ do + let fullf = indir f + r <- catchMaybeIO $ getSymbolicLinkStatus fullf + case r of + Nothing -> return () + Just s + | Files.isDirectory s -> recurse fullf + | Files.isSymbolicLink s -> addSymlinkHook <@> f + | Files.isRegularFile s -> addHook <@> f + | otherwise -> return () + + -- Ignore creation events for regular files, which won't be + -- done being written when initially created, but handle for + -- directories and symlinks. + go (Created { isDirectory = isd, filePath = f }) + | isd = recurse $ indir f + | hashook addSymlinkHook = + whenM (filetype Files.isSymbolicLink f) $ + addSymlinkHook <@> f + | otherwise = noop + -- Closing a file is assumed to mean it's done being written. + go (Closed { isDirectory = False, maybeFilePath = Just f }) = + whenM (filetype Files.isRegularFile f) $ + addHook <@> f + -- When a file or directory is moved in, walk it to add new + -- stuff. + go (MovedIn { filePath = f }) = walk f + go (MovedOut { isDirectory = isd, filePath = f }) + | isd = delDirHook <@> f + | otherwise = delHook <@> f + -- Verify that the deleted item really doesn't exist, + -- since there can be spurious deletion events for items + -- in a directory that has been moved out, but is still + -- being watched. + go (Deleted { isDirectory = isd, filePath = f }) + | isd = guarded $ delDirHook <@> f + | otherwise = guarded $ delHook <@> f + where + guarded = unlessM (filetype (const True) f) go _ = noop - - Just a <@> f = a $ dir </> f - Nothing <@> _ = noop - -{- Pauses the main thread, letting children run until program termination. -} -waitForTermination :: IO () -waitForTermination = do - mv <- newEmptyMVar - check softwareTermination mv - whenM (queryTerminal stdInput) $ - check keyboardSignal mv - takeMVar mv + + hashook h = isJust $ h hooks + + h <@> f + | ignored f = noop + | otherwise = maybe noop (\a -> a $ indir f) (h hooks) + + indir f = dir </> f + + filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) + + -- Inotify fails when there are too many watches with a + -- disk full error. + failedaddwatch e + | isFullError e = + case errHook hooks of + Nothing -> throw e + Just hook -> tooManyWatches hook dir + | otherwise = throw e + +tooManyWatches :: (String -> IO ()) -> FilePath -> IO () +tooManyWatches hook dir = do + sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) + hook $ unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval + where + maxwatches = "fs.inotify.max_user_watches" + basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] + withsysctl n = let new = n * 10 in + [ "Increase the limit permanently by running:" + , " echo " ++ maxwatches ++ "=" ++ show new ++ + " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" + , "Or temporarily by running:" + , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new + ] + +querySysctl :: Read a => [CommandParam] -> IO (Maybe a) +querySysctl ps = do + v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps + case v of + Nothing -> return Nothing + Just (pid, h) -> do + val <- parsesysctl <$> hGetContentsStrict h + void $ getProcessStatus True False $ processID pid + return val where - check sig mv = void $ - installHandler sig (CatchOnce $ putMVar mv ()) Nothing + parsesysctl s = readish =<< lastMaybe (words s) diff --git a/Utility/ThreadLock.hs b/Utility/ThreadLock.hs new file mode 100644 index 000000000..4285c0ec5 --- /dev/null +++ b/Utility/ThreadLock.hs @@ -0,0 +1,35 @@ +{- locking between threads + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.ThreadLock where + +import Common + +import System.Posix.Terminal +import Control.Concurrent.MVar +import System.Posix.Signals + +type Lock = MVar () + +newLock :: IO Lock +newLock = newMVar () + +{- Runs an action with a lock held, so only one thread at a time can run it. -} +withLock :: Lock -> IO a -> IO a +withLock lock = withMVar lock . const + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do + lock <- newEmptyMVar + check softwareTermination lock + whenM (queryTerminal stdInput) $ + check keyboardSignal lock + takeMVar lock + where + check sig lock = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing diff --git a/debian/changelog b/debian/changelog index 8a734e0aa..8c2c68119 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,8 @@ git-annex (3.20120606) UNRELEASED; urgency=low + * watch: New subcommand, which uses inotify to watch for changes to + files and automatically annexes new files, etc, so you don't need + to manually run git commands when manipulating files. * add: Prevent (most) modifications from being made to a file while it is being added to the annex. * initremote: Automatically describe a remote when creating it. diff --git a/debian/control b/debian/control index 2510e2b33..6534fef31 100644 --- a/debian/control +++ b/debian/control @@ -20,6 +20,8 @@ Build-Depends: libghc-ifelse-dev, libghc-bloomfilter-dev, libghc-edit-distance-dev, + libghc-hinotify-dev, + libghc-stm-dev, ikiwiki, perlmagick, git, diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index c7de59cd2..c1d8015ab 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -169,6 +169,13 @@ subdirectories). git annex import /media/camera/DCIM/ +* watch + + Watches for changes to files in the current directory and its subdirectories, + and takes care of automatically adding new files, as well as dealing with + deleted, copied, and moved files. Run this in the background, and you + no longer need to manually run git commands when manipulating your files. + # REPOSITORY SETUP COMMANDS * init [description] diff --git a/doc/install.mdwn b/doc/install.mdwn index fe0522aa0..ec3a7b013 100644 --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -41,6 +41,7 @@ To build and use git-annex, you will need: * [IfElse](http://hackage.haskell.org/package/IfElse) * [bloomfilter](http://hackage.haskell.org/package/bloomfilter) * [edit-distance](http://hackage.haskell.org/package/edit-distance) + * [hinotify](http://hackage.haskell.org/package/hinotify) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) diff --git a/git-annex.cabal b/git-annex.cabal index c15167831..e1ad16453 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -35,7 +35,8 @@ Executable git-annex unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, + hinotify, STM Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c Extensions: CPP @@ -51,7 +52,8 @@ Test-Suite test unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, + hinotify, STM C-Sources: Utility/libdiskfree.c Extensions: CPP diff --git a/git-union-merge.hs b/git-union-merge.hs index 2c2e7a46b..0e4cd644c 100644 --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -28,7 +28,7 @@ setup :: Git.Repo -> IO () setup = cleanup -- idempotency cleanup :: Git.Repo -> IO () -cleanup g = whenM (doesFileExist $ tmpIndex g) $ removeFile $ tmpIndex g +cleanup g = nukeFile $ tmpIndex g parseArgs :: IO [String] parseArgs = do |