diff options
41 files changed, 963 insertions, 193 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..8e7f45a4a 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 @@ -66,7 +68,7 @@ siblingBranches = inRepo $ Git.Ref.matchingUniq name {- Creates the branch, if it does not already exist. -} create :: Annex () -create = void $ getBranch +create = void getBranch {- Returns the ref of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref @@ -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/CatFile.hs b/Annex/CatFile.hs index bcf44551e..afb14c67f 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -8,6 +8,7 @@ module Annex.CatFile ( catFile, catObject, + catObjectDetails, catFileHandle ) where @@ -17,6 +18,7 @@ import Common.Annex import qualified Git import qualified Git.CatFile import qualified Annex +import Git.Types catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do @@ -28,6 +30,11 @@ catObject ref = do h <- catFileHandle liftIO $ Git.CatFile.catObject h ref +catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha)) +catObjectDetails ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObjectDetails h ref + catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle where diff --git a/Annex/Content.hs b/Annex/Content.hs index 26b332e24..3e3e95868 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -87,7 +87,7 @@ lockContent key a = do - to fiddle with permissions to open for an exclusive lock. -} openforlock f = catchMaybeIO $ ifM (doesFileExist f) ( withModifiedFileMode f - (\cur -> cur `unionFileModes` ownerWriteMode) + (`unionFileModes` ownerWriteMode) open , open ) @@ -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..ccdff67ec 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,29 @@ 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. -} +link :: FilePath -> Key -> Bool -> Annex () +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 +{- 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/Commit.hs b/Command/Commit.hs index 1c82ed7df..f53ab7e09 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -22,7 +22,7 @@ seek = [withNothing start] start :: CommandStart start = next $ next $ do Annex.Branch.commit "update" - _ <- runhook =<< (inRepo $ Git.hookPath "annex-content") + _ <- runhook =<< inRepo (Git.hookPath "annex-content") return True where runhook (Just hook) = liftIO $ boolSystem hook [] 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..7bfc46f4a 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -145,17 +145,17 @@ fixLink key file = do -} whenM (liftIO $ doesFileExist file) $ unlessM (inAnnex key) $ do - showNote $ "fixing content location" + showNote "fixing content location" dir <- liftIO $ parentDir <$> absPath file let content = absPathFrom dir have liftIO $ allowWrite (parentDir content) moveAnnex key content - showNote $ "fixing link" + showNote "fixing link" 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, @@ -220,7 +220,7 @@ checkKeySize' key file bad = case Types.Key.keySize key of Nothing -> return True Just size -> do size' <- fromIntegral . fileSize - <$> (liftIO $ getFileStatus file) + <$> liftIO (getFileStatus file) comparesizes size size' where comparesizes a b = do diff --git a/Command/Get.hs b/Command/Get.hs index 772fbd90c..c4ba48312 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -26,7 +26,7 @@ start from file (key, _) = stopUnless (not <$> inAnnex key) $ autoCopies file key (<) $ \_numcopies -> case from of Nothing -> go $ perform key - Just src -> do + Just src -> -- get --from = copy --from stopUnless (Command.Move.fromOk src key) $ go $ Command.Move.fromPerform src False 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/Move.hs b/Command/Move.hs index 8612c9f2d..6ec7cd90a 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -128,9 +128,9 @@ fromOk src key expensive = do u <- getUUID remotes <- Remote.keyPossibilities key - return $ u /= Remote.uuid src && any (== src) remotes + return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> Bool -> Key -> CommandPerform -fromPerform src move key = moveLock move key $ do +fromPerform src move key = moveLock move key $ ifM (inAnnex key) ( handle move True , do diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 5724bffd0..46a2480e6 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -28,8 +28,8 @@ check = do "cannot uninit when the " ++ show b ++ " branch is checked out" top <- fromRepo Git.repoPath cwd <- liftIO getCurrentDirectory - whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ error $ - "can only run uninit from the top of the git repository" + whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ + error "can only run uninit from the top of the git repository" where current_branch = Git.Ref . Prelude.head . lines <$> revhead revhead = inRepo $ Git.Command.pipeRead diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..0ee932dba --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +{- git-annex watch daemon + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + - + - Overview of threads and MVars, etc: + - + - Thread 1: parent + - The initial thread run, double forks to background, starts other + - threads, and then stops, waiting for them to terminate, + - or for a ctrl-c. + - Thread 2: inotify + - Notices new files, and calls handlers for events, queuing changes. + - Thread 3: inotify internal + - Used by haskell inotify library to ensure inotify event buffer is + - kept drained. + - Thread 4: committer + - Waits for changes to occur, and runs the git queue to update its + - index, then commits. + - + - State MVar: + - The Annex state is stored here, which allows resuscitating the + - Annex monad in IO actions run by the inotify and committer + - threads. Thus, a single state is shared amoung the threads, and + - only one at a time can access it. + - ChangeChan STM TChan: + - Changes are indicated by writing to this channel. The committer + - reads from it. + -} + +module Command.Watch where + +import Common.Annex +import Command +import Utility.Daemon +import Utility.LogFile +import Utility.ThreadLock +import qualified Annex +import qualified Annex.Queue +import qualified Command.Add +import qualified Git.Command +import qualified Git.UpdateIndex +import qualified Git.HashObject +import qualified Backend +import Annex.Content +import Annex.CatFile +import Git.Types +import Option + +import Control.Concurrent +import Control.Concurrent.STM +import Data.Time.Clock +import Data.Bits.Utils +import qualified Data.ByteString.Lazy as L + +#if defined linux_HOST_OS +import Utility.Inotify +import System.INotify +#endif + +type ChangeChan = TChan Change + +type Handler = FilePath -> Annex (Maybe Change) + +data Change = Change + { changeTime :: UTCTime + , changeFile :: FilePath + , changeDesc :: String + } + deriving (Show) + +def :: [Command] +def = [withOptions [foregroundOption, stopOption] $ + command "watch" paramPaths seek "watch for changes"] + +seek :: [CommandSeek] +seek = [withFlag stopOption $ \stopdaemon -> + withFlag foregroundOption $ \foreground -> + withNothing $ start foreground stopdaemon] + +foregroundOption :: Option +foregroundOption = Option.flag [] "foreground" "do not daemonize" + +stopOption :: Option +stopOption = Option.flag [] "stop" "stop daemon" + +start :: Bool -> Bool -> CommandStart +start foreground stopdaemon = notBareRepo $ do + if stopdaemon + then liftIO . stopDaemon =<< fromRepo gitAnnexPidFile + else withStateMVar $ startDaemon (not foreground) + stop + +startDaemon :: Bool -> MVar Annex.AnnexState -> Annex () +startDaemon False st = do + showStart "watch" "." + liftIO $ watch st +startDaemon True st = do + logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile + pidfile <- fromRepo gitAnnexPidFile + liftIO $ daemonize logfd (Just pidfile) False $ watch st + +watch :: MVar Annex.AnnexState -> IO () +#if defined linux_HOST_OS +watch st = withINotify $ \i -> do + changechan <- runChangeChan newTChan + let hook a = Just $ runHandler st changechan a + let hooks = WatchHooks + { addHook = hook onAdd + , delHook = hook onDel + , addSymlinkHook = hook onAddSymlink + , delDirHook = hook onDelDir + , errHook = hook onErr + } + -- The commit thread is started early, so that the user + -- can immediately begin adding files and having them + -- committed, even while the inotify scan is taking place. + _ <- forkIO $ commitThread st changechan + -- This does not return until the inotify scan is done. + -- That can take some time for large trees. + watchDir i "." (ignored . takeFileName) hooks + runStateMVar st $ showAction "scanning" + -- Notice any files that were deleted before inotify + -- was started. + runStateMVar st $ do + inRepo $ Git.Command.run "add" [Param "--update"] + showAction "started" + waitForTermination +#else +watch = 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 a -> IO a +runStateMVar mvar a = do + liftIO $ putStrLn "takeMVar" + startstate <- takeMVar mvar + !(r, newstate) <- Annex.run startstate a + liftIO $ putStrLn "putMVar" + putMVar mvar newstate + return r + +runChangeChan :: STM a -> IO a +runChangeChan = atomically + +{- Runs an action handler, inside the Annex monad, and if there was a + - change, adds it to the ChangeChan. + - + - Exceptions are ignored, otherwise a whole watcher thread could be crashed. + -} +runHandler :: MVar Annex.AnnexState -> ChangeChan -> Handler -> FilePath -> IO () +runHandler st changechan handler file = void $ do + r <- tryIO (runStateMVar st $ handler file) + case r of + Left e -> print e + Right Nothing -> noop + Right (Just change) -> void $ + runChangeChan $ writeTChan changechan change + +{- Handlers call this when they made a change that needs to get committed. -} +madeChange :: FilePath -> String -> Annex (Maybe Change) +madeChange file desc = do + -- Just in case the commit thread is not flushing the queue fast enough. + Annex.Queue.flushWhenFull + liftIO $ Just <$> (Change <$> getCurrentTime <*> pure file <*> pure desc) + +noChange :: Annex (Maybe Change) +noChange = return Nothing + +{- 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. + - + - 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 + handle =<< Command.Add.ingest file + noChange + where + 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 :: Handler +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 + ) + {- This is often called on symlinks that are already staged + - correctly, especially during the startup scan. A symlink + - may have been deleted and re-added, or added when + - the watcher was not running; so it always stages + - even symlinks that already exist. + - + - So for speed, tries to reuse the existing blob for + - the symlink target. -} + addlink link = do + v <- catObjectDetails $ Ref $ ':':file + case v of + Just (currlink, sha) + | s2w8 link == L.unpack currlink -> + stageSymlink file sha + _ -> do + sha <- inRepo $ + Git.HashObject.hashObject BlobObject link + stageSymlink file sha + madeChange file "link" + +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, + - 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 :: 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 :: Handler +onErr msg = do + warning msg + return Nothing + +{- Adds a symlink to the index, without ever accessing the actual symlink + - on disk. -} +stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink file sha = + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.stageSymlink file sha) + +{- Gets all unhandled changes. + - Blocks until at least one change is made. -} +getChanges :: ChangeChan -> IO [Change] +getChanges chan = runChangeChan $ 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 -> [Change] -> IO () +refillChanges chan cs = runChangeChan $ mapM_ (writeTChan chan) cs + +{- This thread makes git commits at appropriate times. -} +commitThread :: MVar Annex.AnnexState -> ChangeChan -> IO () +commitThread st changechan = forever $ do + -- First, a simple rate limiter. + threadDelay oneSecond + -- Next, wait until at least one change has been made. + cs <- getChanges changechan + -- Now see if now's a good time to commit. + time <- getCurrentTime + if shouldCommit time cs + then void $ tryIO $ runStateMVar st commitStaged + else refillChanges changechan cs + where + 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 -> [Change] -> Bool +shouldCommit now changes + | len == 0 = False + | len > 4096 = True -- avoid bloating queue too much + | length (filter thisSecond changes) < 10 = True + | otherwise = False -- batch activity + where + len = length changes + thisSecond c = now `diffUTCTime` changeTime c <= 1 diff --git a/Command/Whereis.hs b/Command/Whereis.hs index eb6ea7c56..b697bf554 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -37,7 +37,7 @@ perform remotemap key = do unless (null safelocations) $ showLongNote pp pp' <- prettyPrintUUIDs "untrusted" untrustedlocations unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp' - forM_ (catMaybes $ map (`M.lookup` remotemap) locations) $ + forM_ (mapMaybe (`M.lookup` remotemap) locations) $ performRemote key if null safelocations then stop else next $ return True where @@ -114,6 +114,6 @@ getDiskReserve = fromMaybe megabyte . readSize dataUnits getHttpHeaders :: Annex [String] getHttpHeaders = do cmd <- getConfig (annexConfig "http-headers-command") "" - if (null cmd) + if null cmd then fromRepo $ Git.Config.getList "annex.http-headers" else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd]) @@ -138,7 +138,7 @@ withDecryptedContent = pass withDecryptedHandle pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a -pass to n s a = to n s $ \h -> a =<< L.hGetContents h +pass to n s a = to n s $ a <=< L.hGetContents hmacWithCipher :: Cipher -> String -> String hmacWithCipher c = hmacWithCipher' (cipherHmac c) diff --git a/Git/CatFile.hs b/Git/CatFile.hs index d5b367945..8a320a712 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -10,7 +10,8 @@ module Git.CatFile ( catFileStart, catFileStop, catFile, - catObject + catObject, + catObjectDetails, ) where import System.IO @@ -42,7 +43,11 @@ catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString -catObject h object = CoProcess.query h send receive +catObject h object = maybe L.empty fst <$> catObjectDetails h object + +{- Gets both the content of an object, and its Sha. -} +catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) +catObjectDetails h object = CoProcess.query h send receive where send to = do fileEncoding to @@ -55,16 +60,16 @@ catObject h object = CoProcess.query h send receive | length sha == shaSize && isJust (readObjectType objtype) -> case reads size of - [(bytes, "")] -> readcontent bytes from + [(bytes, "")] -> readcontent bytes from sha _ -> dne | otherwise -> dne _ | header == show object ++ " missing" -> dne | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) - readcontent bytes from = do + readcontent bytes from sha = do content <- S.hGet from bytes c <- hGetChar from when (c /= '\n') $ error "missing newline from git cat-file" - return $ L.fromChunks [content] - dne = return L.empty + return $ Just (L.fromChunks [content], Ref sha) + dne = return Nothing 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..31e8a45b2 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -5,26 +5,38 @@ - 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.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 +49,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 -> Sha -> Repo -> IO Streamer +stageSymlink file sha repo = do + line <- updateIndexLine + <$> pure sha + <*> 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/Locations.hs b/Locations.hs index db456388a..0c9935614 100644 --- a/Locations.hs +++ b/Locations.hs @@ -23,6 +23,8 @@ module Locations ( gitAnnexIndex, gitAnnexIndexLock, gitAnnexIndexDirty, + gitAnnexPidFile, + gitAnnexLogFile, gitAnnexSshDir, gitAnnexRemotesDir, isLinkToAnnex, @@ -145,6 +147,14 @@ gitAnnexIndexLock r = gitAnnexDir r </> "index.lck" gitAnnexIndexDirty :: Git.Repo -> FilePath gitAnnexIndexDirty r = gitAnnexDir r </> "index.dirty" +{- Pid file for daemon mode. -} +gitAnnexPidFile :: Git.Repo -> FilePath +gitAnnexPidFile r = gitAnnexDir r </> "daemon.pid" + +{- Log file for daemon mode. -} +gitAnnexLogFile :: Git.Repo -> FilePath +gitAnnexLogFile r = gitAnnexDir r </> "daemon.log" + {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r </> "ssh" @@ -155,7 +165,7 @@ gitAnnexRemotesDir r = addTrailingPathSeparator $ gitAnnexDir r </> "remotes" {- Checks a symlink target to see if it appears to point to annexed content. -} isLinkToAnnex :: FilePath -> Bool -isLinkToAnnex s = ("/" ++ d) `isInfixOf` s || d `isPrefixOf` s +isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s where d = ".git" </> objectDir diff --git a/Messages.hs b/Messages.hs index 96bf3ae4b..1b48c119b 100644 --- a/Messages.hs +++ b/Messages.hs @@ -183,7 +183,7 @@ setupConsole = do fileEncoding stderr handle :: IO () -> IO () -> Annex () -handle json normal = withOutputType $ go +handle json normal = withOutputType go where go NormalOutput = liftIO normal go QuietOutput = q 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/Daemon.hs b/Utility/Daemon.hs new file mode 100644 index 000000000..3d2faed67 --- /dev/null +++ b/Utility/Daemon.hs @@ -0,0 +1,71 @@ +{- daemon support + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Daemon where + +import Common + +import System.Posix + +{- Run an action as a daemon, with all output sent to a file descriptor. + - + - Can write its pid to a file, to guard against multiple instances + - running and allow easy termination. + - + - When successful, does not return. -} +daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO () +daemonize logfd pidfile changedirectory a = do + _ <- forkProcess child1 + out + where + child1 = do + _ <- createSession + _ <- forkProcess child2 + out + child2 = do + maybe noop (lockPidFile True alreadyrunning) pidfile + when changedirectory $ + setCurrentDirectory "/" + nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags + _ <- redir nullfd stdInput + mapM_ (redir logfd) [stdOutput, stdError] + closeFd logfd + a + out + redir newh h = do + closeFd h + dupTo newh h + alreadyrunning = error "Daemon is already running." + out = exitImmediately ExitSuccess + +lockPidFile :: Bool -> IO () -> FilePath -> IO () +lockPidFile write onfailure file = do + fd <- openFd file ReadWrite (Just stdFileMode) defaultFileFlags + locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0) + case locked of + Nothing -> onfailure + _ -> when write $ void $ + fdWrite fd =<< show <$> getProcessID + where + locktype + | write = WriteLock + | otherwise = ReadLock + +{- Stops the daemon. + - + - The pid file is used to get the daemon's pid. + - + - To guard against a stale pid, try to take a nonblocking shared lock + - of the pid file. If this *fails*, the daemon must be running, + - and have the exclusive lock, so the pid file is trustworthy. + -} +stopDaemon :: FilePath -> IO () +stopDaemon pidfile = lockPidFile False go pidfile + where + go = do + pid <- readish <$> readFile pidfile + maybe noop (signalProcess sigTERM) pid diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 5bfd49a9c..78bb6e701 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -10,12 +10,11 @@ module Utility.Directory where import System.IO.Error import System.Posix.Files import System.Directory -import Control.Exception (throw) +import Control.Exception (throw, bracket_) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative -import Control.Exception (bracket_) import System.Posix.Directory import System.IO.Unsafe (unsafeInterleaveIO) @@ -88,6 +87,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/LogFile.hs b/Utility/LogFile.hs new file mode 100644 index 000000000..7ffb63f52 --- /dev/null +++ b/Utility/LogFile.hs @@ -0,0 +1,31 @@ +{- log files + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.LogFile where + +import Common + +import System.Posix + +openLog :: FilePath -> IO Fd +openLog logfile = do + rotateLog logfile 0 + openFd logfile WriteOnly (Just stdFileMode) + defaultFileFlags { append = True } + +rotateLog :: FilePath -> Int -> IO () +rotateLog logfile num + | num >= 10 = return () + | otherwise = whenM (doesFileExist currfile) $ do + rotateLog logfile (num + 1) + renameFile currfile nextfile + where + currfile = filename num + nextfile = filename (num + 1) + filename n + | n == 0 = logfile + | otherwise = logfile ++ "." ++ show n 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 67ecdda45..60a42dcde 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,8 @@ git-annex (3.20120612) 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. * Install man page when run by cabal, in a location where man will find it, even when installing under $HOME. Thanks, Nathan Collins 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..39fad0488 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -169,6 +169,17 @@ 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. With this running as a daemon in the + background, you no longer need to manually run git commands when + manipulating your files. + + To not daemonize, run with --foreground ; to stop a running daemon, + run with --stop + # REPOSITORY SETUP COMMANDS * init [description] diff --git a/doc/install.mdwn b/doc/install.mdwn index fe0522aa0..5aec2e914 100644 --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -41,6 +41,8 @@ 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) + * [stm](http://hackage.haskell.org/package/stm) + * [hinotify](http://hackage.haskell.org/package/hinotify) (on Linux only) * 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 9703b61f0..7556f7541 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -34,7 +34,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 -- Need to list this because it's generated from a .hsc file. Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c @@ -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 Other-Modules: Utility.Touch 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 |