diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Add.hs | 56 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Watch.hs | 150 |
3 files changed, 186 insertions, 22 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 2c671eea2..ea0f85033 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,21 +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, 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 [] 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/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..046fca7d1 --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,150 @@ +{- 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.Inotify +import Utility.ThreadLock +import qualified Annex +import qualified Command.Add +import qualified Git +import qualified Git.Command +import qualified Git.UpdateIndex +import Git.HashObject +import Git.Types +import Git.FilePath +import qualified Backend +import Annex.Content + +import Control.Exception as E +import Control.Concurrent.MVar + +#if defined linux_HOST_OS +import System.INotify +#endif + +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"] + state <- Annex.getState id + mvar <- liftIO $ newMVar state + next $ next $ liftIO $ withINotify $ \i -> do + let hook a = Just $ runAnnex mvar 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 + +{- Runs a handler, inside the Annex monad. + - + - Exceptions by the handlers are ignored, otherwise a whole watcher + - thread could be crashed. + -} +runAnnex :: MVar Annex.AnnexState -> (FilePath -> Annex a) -> FilePath -> IO () +runAnnex mvar a f = do + startstate <- takeMVar mvar + r <- E.try (go startstate) :: IO (Either E.SomeException Annex.AnnexState) + case r of + Left e -> do + putStrLn (show e) + putMVar mvar startstate + Right !newstate -> + putMVar mvar newstate + where + go state = Annex.exec state $ a f + +{- 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 + inRepo $ 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 = inRepo $ stageSymlink file link + +{- The file could reappear at any time, so --cached is used, to only delete + - it from the index. -} +onDel :: FilePath -> Annex () +onDel file = inRepo $ Git.Command.run "rm" + [Params "--quiet --cached --ignore-unmatch --", File file] + +{- A directory has been deleted, or moved, so tell git to remove anything + - that was inside it from its cache. -} +onDelDir :: FilePath -> Annex () +onDelDir dir = inRepo $ Git.Command.run "rm" + [Params "--quiet -r --cached --ignore-unmatch --", File 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 -> Git.Repo -> IO () +stageSymlink file linktext repo = Git.UpdateIndex.stream_update_index repo [stage] + where + stage streamer = do + line <- Git.UpdateIndex.update_index_line + <$> (hashObject repo BlobObject linktext) + <*> pure SymlinkBlob + <*> toTopFilePath file repo + streamer line |