diff options
author | 2013-11-14 17:04:58 -0400 | |
---|---|---|
committer | 2013-11-14 17:04:58 -0400 | |
commit | 521ef9dfebd6a9418a5dce7d1686dbf353ddd0a0 (patch) | |
tree | afe6bb5d52e21a049f04020ae448afb81adc02a7 /Command | |
parent | f4b4f327b69189d24663a7db6407c1f7a6e48fdd (diff) | |
parent | 5c6f6e4d0abb9b4856908a500611044b3b7a48e6 (diff) |
Merge branch 'master' into tasty-tests
Conflicts:
Test.hs
Diffstat (limited to 'Command')
46 files changed, 1479 insertions, 684 deletions
diff --git a/Command/Add.hs b/Command/Add.hs index 245ca2bd6..9f1beb28a 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -23,10 +23,11 @@ import Annex.Perms import Annex.Link import qualified Annex import qualified Annex.Queue +#ifdef WITH_CLIBS #ifndef __ANDROID__ import Utility.Touch #endif -import Utility.FileMode +#endif import Config import Utility.InodeCache import Annex.FileMatcher @@ -77,7 +78,7 @@ start file = ifAnnexed file addpresent add -- is present but not yet added to git showStart "add" file liftIO $ removeFile file - next $ next $ cleanup file key =<< inAnnex key + next $ next $ cleanup file key Nothing =<< inAnnex key {- The file that's being added is locked down before a key is generated, - to prevent it from being modified in between. This lock down is not @@ -86,11 +87,6 @@ start file = ifAnnexed file addpresent add - So a KeySource is returned. Its inodeCache can be used to detect any - changes that might be made to the file after it was locked down. - - - In indirect mode, the write bit is removed from the file as part of lock - - down to guard against further writes, and because objects in the annex - - have their write bit disabled anyway. This is not done in direct mode, - - because files there need to remain writable at all times. - - - When possible, the file is hard linked to a temp directory. This guards - against some changes, like deletion or overwrite of the file, and - allows lsof checks to be done more efficiently when adding a lot of files. @@ -98,24 +94,36 @@ start file = ifAnnexed file addpresent add - Lockdown can fail if a file gets deleted, and Nothing will be returned. -} lockDown :: FilePath -> Annex (Maybe KeySource) -lockDown file = ifM (crippledFileSystem) +lockDown file = ifM crippledFileSystem ( liftIO $ catchMaybeIO nohardlink , do tmp <- fromRepo gitAnnexTmpDir createAnnexDirectory tmp - unlessM (isDirect) $ liftIO $ - void $ tryIO $ preventWrite file - liftIO $ catchMaybeIO $ do + eitherToMaybe <$> tryAnnexIO (go tmp) + ) + where + {- In indirect mode, the write bit is removed from the file as part + - of lock down to guard against further writes, and because objects + - in the annex have their write bit disabled anyway. + - + - Freezing the content early also lets us fail early when + - someone else owns the file. + - + - This is not done in direct mode, because files there need to + - remain writable at all times. + -} + go tmp = do + unlessM isDirect $ + freezeContent file + liftIO $ do (tmpfile, h) <- openTempFile tmp $ relatedTemplate $ takeFileName file hClose h nukeFile tmpfile withhardlink tmpfile `catchIO` const nohardlink - ) - where nohardlink = do cache <- genInodeCache file - return $ KeySource + return KeySource { keyFilename = file , contentLocation = file , inodeCache = cache @@ -123,7 +131,7 @@ lockDown file = ifM (crippledFileSystem) withhardlink tmpfile = do createLink file tmpfile cache <- genInodeCache tmpfile - return $ KeySource + return KeySource { keyFilename = file , contentLocation = tmpfile , inodeCache = cache @@ -134,8 +142,8 @@ lockDown file = ifM (crippledFileSystem) - In direct mode, leaves the file alone, and just updates bookkeeping - information. -} -ingest :: (Maybe KeySource) -> Annex (Maybe Key) -ingest Nothing = return Nothing +ingest :: Maybe KeySource -> Annex (Maybe Key, Maybe InodeCache) +ingest Nothing = return (Nothing, Nothing) ingest (Just source) = do backend <- chooseBackend $ keyFilename source k <- genKey source backend @@ -147,24 +155,24 @@ ingest (Just source) = do where go k cache = ifM isDirect ( godirect k cache , goindirect k cache ) - goindirect (Just (key, _)) _ = do + goindirect (Just (key, _)) mcache = do catchAnnex (moveAnnex key $ contentLocation source) (undo (keyFilename source) key) liftIO $ nukeFile $ keyFilename source - return $ Just key + return $ (Just key, mcache) goindirect Nothing _ = failure "failed to generate a key" godirect (Just (key, _)) (Just cache) = do addInodeCache key cache finishIngestDirect key source - return $ Just key + return $ (Just key, Just cache) godirect _ _ = failure "failed to generate a key" failure msg = do warning $ keyFilename source ++ " " ++ msg when (contentLocation source /= keyFilename source) $ liftIO $ nukeFile $ contentLocation source - return Nothing + return (Nothing, Nothing) finishIngestDirect :: Key -> KeySource -> Annex () finishIngestDirect key source = do @@ -178,9 +186,10 @@ finishIngestDirect key source = do addContentWhenNotPresent key (keyFilename source) perform :: FilePath -> CommandPerform -perform file = - maybe stop (\key -> next $ cleanup file key True) - =<< ingest =<< lockDown file +perform file = lockDown file >>= ingest >>= go + where + go (Just key, cache) = next $ cleanup file key cache True + go (Nothing, _) = stop {- 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. -} @@ -199,18 +208,19 @@ undo file key e = do liftIO $ moveFile src file {- Creates the symlink to the annexed content, returns the link target. -} -link :: FilePath -> Key -> Bool -> Annex String -link file key hascontent = flip catchAnnex (undo file key) $ do +link :: FilePath -> Key -> Maybe InodeCache -> Annex String +link file key mcache = flip catchAnnex (undo file key) $ do l <- inRepo $ gitAnnexLink file key replaceFile file $ makeAnnexLink l +#ifdef WITH_CLIBS #ifndef __ANDROID__ - when hascontent $ do - -- 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 symlink to have same time as the original file, + -- as provided in the InodeCache + case mcache of + Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False + Nothing -> noop +#endif #endif return l @@ -224,28 +234,28 @@ link file key hascontent = flip catchAnnex (undo file key) $ do - Also, using git add allows it to skip gitignored files, unless forced - to include them. -} -addLink :: FilePath -> Key -> Bool -> Annex () -addLink file key hascontent = ifM (coreSymlinks <$> Annex.getGitConfig) +addLink :: FilePath -> Key -> Maybe InodeCache -> Annex () +addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) ( do - _ <- link file key hascontent + _ <- link file key mcache params <- ifM (Annex.getState Annex.force) ( return [Param "-f"] , return [] ) Annex.Queue.addCommand "add" (params++[Param "--"]) [file] , do - l <- link file key hascontent + l <- link file key mcache addAnnexLink l file ) -cleanup :: FilePath -> Key -> Bool -> CommandCleanup -cleanup file key hascontent = do +cleanup :: FilePath -> Key -> Maybe InodeCache -> Bool -> CommandCleanup +cleanup file key mcache hascontent = do when hascontent $ logStatus key InfoPresent ifM (isDirect <&&> pure hascontent) ( do l <- inRepo $ gitAnnexLink file key stageSymlink file =<< hashSymlink l - , addLink file key hascontent + , addLink file key mcache ) return True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 21a75137f..1a178e8d4 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -29,7 +29,7 @@ start = startUnused "addunused" perform perform :: Key -> CommandPerform perform key = next $ do logStatus key InfoPresent - Command.Add.addLink file key False + Command.Add.addLink file key Nothing return True where file = "unused." ++ key2file key diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index d172a6869..27ca72d1a 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Command.AddUrl where import Network.URI @@ -15,8 +17,8 @@ import Backend import qualified Command.Add import qualified Annex import qualified Annex.Queue +import qualified Annex.Url as Url import qualified Backend.URL -import qualified Utility.Url as Url import Annex.Content import Logs.Web import qualified Option @@ -27,6 +29,10 @@ import Annex.Content.Direct import Logs.Location import qualified Logs.Transfer as Transfer import Utility.Daemon (checkDaemon) +#ifdef WITH_QUVI +import Annex.Quvi +import qualified Utility.Quvi as Quvi +#endif def :: [Command] def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $ @@ -51,15 +57,64 @@ seek = [withField fileOption return $ \f -> start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s where - bad = fromMaybe (error $ "bad url " ++ s) $ - parseURI $ escapeURIString isUnescapedInURI s - go url = do + (s', downloader) = getDownloader s + bad = fromMaybe (error $ "bad url " ++ s') $ + parseURI $ escapeURIString isUnescapedInURI s' + choosefile = flip fromMaybe optfile + go url = case downloader of + QuviDownloader -> usequvi + DefaultDownloader -> +#ifdef WITH_QUVI + ifM (liftIO $ Quvi.supported s') + ( usequvi + , regulardownload url + ) +#else + regulardownload url +#endif + regulardownload url = do + pathmax <- liftIO $ fileNameLengthLimit "." + let file = choosefile $ url2file url pathdepth pathmax + showStart "addurl" file + next $ perform relaxed s' file +#ifdef WITH_QUVI + badquvi = error $ "quvi does not know how to download url " ++ s' + usequvi = do + page <- fromMaybe badquvi + <$> withQuviOptions Quvi.forceQuery [Quvi.quiet, Quvi.httponly] s' + let link = fromMaybe badquvi $ headMaybe $ Quvi.pageLinks page pathmax <- liftIO $ fileNameLengthLimit "." - let file = fromMaybe (url2file url pathdepth pathmax) optfile + let file = choosefile $ truncateFilePath pathmax $ sanitizeFilePath $ + Quvi.pageTitle page ++ "." ++ Quvi.linkSuffix link showStart "addurl" file - next $ perform relaxed s file + next $ performQuvi relaxed s' (Quvi.linkUrl link) file +#else + usequvi = error "not built with quvi support" +#endif -perform :: Bool -> String -> FilePath -> CommandPerform +#ifdef WITH_QUVI +performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform +performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl + where + quviurl = setDownloader pageurl QuviDownloader + addurl (key, _backend) = next $ cleanup quviurl file key Nothing + geturl = do + key <- Backend.URL.fromUrl quviurl Nothing + ifM (pure relaxed <||> Annex.getState Annex.fast) + ( next $ cleanup quviurl file key Nothing + , do + tmp <- fromRepo $ gitAnnexTmpLocation key + showOutput + ok <- Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do + liftIO $ createDirectoryIfMissing True (parentDir tmp) + downloadUrl [videourl] tmp + if ok + then next $ cleanup quviurl file key (Just tmp) + else stop + ) +#endif + +perform :: Bool -> URLString -> FilePath -> CommandPerform perform relaxed url file = ifAnnexed file addurl geturl where geturl = next $ addUrlFile relaxed url file @@ -69,16 +124,18 @@ perform relaxed url file = ifAnnexed file addurl geturl next $ return True | otherwise = do headers <- getHttpHeaders - ifM (liftIO $ Url.check url headers $ keySize key) - ( do + (exists, samesize) <- Url.withUserAgent $ Url.check url headers $ keySize key + if exists && samesize + then do setUrlPresent key url next $ return True - , do - warning $ "failed to verify url exists: " ++ url + else do + warning $ if exists + then "url does not have expected file size (use --relaxed to bypass this check) " ++ url + else "failed to verify url exists: " ++ url stop - ) -addUrlFile :: Bool -> String -> FilePath -> Annex Bool +addUrlFile :: Bool -> URLString -> FilePath -> Annex Bool addUrlFile relaxed url file = do liftIO $ createDirectoryIfMissing True (parentDir file) ifM (Annex.getState Annex.fast <||> pure relaxed) @@ -88,7 +145,7 @@ addUrlFile relaxed url file = do download url file ) -download :: String -> FilePath -> Annex Bool +download :: URLString -> FilePath -> Annex Bool download url file = do dummykey <- genkey tmp <- fromRepo $ gitAnnexTmpLocation dummykey @@ -120,7 +177,7 @@ download url file = do size <- ifM (liftIO $ isJust <$> checkDaemon pidfile) ( do headers <- getHttpHeaders - liftIO $ snd <$> Url.exists url headers + snd <$> Url.withUserAgent (Url.exists url headers) , return Nothing ) Backend.URL.fromUrl url size @@ -130,12 +187,12 @@ download url file = do downloadUrl [url] tmp -cleanup :: String -> FilePath -> Key -> Maybe FilePath -> Annex Bool +cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool cleanup url file key mtmp = do when (isJust mtmp) $ logStatus key InfoPresent setUrlPresent key url - Command.Add.addLink file key False + Command.Add.addLink file key Nothing whenM isDirect $ do void $ addAssociatedFile key file {- For moveAnnex to work in direct mode, the symlink @@ -144,12 +201,12 @@ cleanup url file key mtmp = do maybe noop (moveAnnex key) mtmp return True -nodownload :: Bool -> String -> FilePath -> Annex Bool +nodownload :: Bool -> URLString -> FilePath -> Annex Bool nodownload relaxed url file = do headers <- getHttpHeaders (exists, size) <- if relaxed then pure (True, Nothing) - else liftIO $ Url.exists url headers + else Url.withUserAgent $ Url.exists url headers if exists then do key <- Backend.URL.fromUrl url size @@ -160,7 +217,7 @@ nodownload relaxed url file = do url2file :: URI -> Maybe Int -> Int -> FilePath url2file url pathdepth pathmax = case pathdepth of - Nothing -> truncateFilePath pathmax $ escape fullurl + Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl Just depth | depth >= length urlbits -> frombits id | depth > 0 -> frombits $ drop depth @@ -169,6 +226,6 @@ url2file url pathdepth pathmax = case pathdepth of where fullurl = uriRegName auth ++ uriPath url ++ uriQuery url frombits a = intercalate "/" $ a urlbits - urlbits = map (truncateFilePath pathmax . escape) $ filter (not . null) $ split "/" fullurl + urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $ + filter (not . null) $ split "/" fullurl auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url - escape = replace "/" "_" . replace "?" "_" diff --git a/Command/Assistant.hs b/Command/Assistant.hs index f65bed736..521a88571 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -14,43 +14,55 @@ import qualified Command.Watch import Init import Config.Files import qualified Build.SysConfig +import Utility.HumanTime import System.Environment def :: [Command] -def = [noRepo checkAutoStart $ dontCheck repoExists $ - withOptions [Command.Watch.foregroundOption, Command.Watch.stopOption, autoStartOption] $ +def = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $ command "assistant" paramNothing seek SectionCommon "automatically handle changes"] +options :: [Option] +options = + [ Command.Watch.foregroundOption + , Command.Watch.stopOption + , autoStartOption + , startDelayOption + ] + autoStartOption :: Option autoStartOption = Option.flag [] "autostart" "start in known repositories" +startDelayOption :: Option +startDelayOption = Option.field [] "startdelay" paramNumber "delay before running startup scan" + seek :: [CommandSeek] seek = [withFlag Command.Watch.stopOption $ \stopdaemon -> withFlag Command.Watch.foregroundOption $ \foreground -> withFlag autoStartOption $ \autostart -> - withNothing $ start foreground stopdaemon autostart] + withField startDelayOption (pure . maybe Nothing parseDuration) $ \startdelay -> + withNothing $ start foreground stopdaemon autostart startdelay] -start :: Bool -> Bool -> Bool -> CommandStart -start foreground stopdaemon autostart +start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart +start foreground stopdaemon autostart startdelay | autostart = do - liftIO autoStart + liftIO $ autoStart startdelay stop | otherwise = do ensureInitialized - Command.Watch.start True foreground stopdaemon + Command.Watch.start True foreground stopdaemon startdelay {- Run outside a git repository. Check to see if any parameter is - --autostart and enter autostart mode. -} checkAutoStart :: IO () checkAutoStart = ifM (elem "--autostart" <$> getArgs) - ( autoStart + ( autoStart Nothing , error "Not in a git repository." ) -autoStart :: IO () -autoStart = do +autoStart :: Maybe Duration -> IO () +autoStart startdelay = do dirs <- liftIO readAutoStartFile when (null dirs) $ do f <- autoStartFile @@ -67,5 +79,10 @@ autoStart = do go haveionice program dir = do setCurrentDirectory dir if haveionice - then boolSystem "ionice" [Param "-c3", Param program, Param "assistant"] - else boolSystem program [Param "assistant"] + then boolSystem "ionice" (Param "-c3" : Param program : baseparams) + else boolSystem program baseparams + where + baseparams = + [ Param "assistant" + , Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) startdelay) + ] diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 703d6882d..c42480200 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -10,6 +10,8 @@ module Command.ConfigList where import Common.Annex import Command import Annex.UUID +import qualified Git.Config +import Remote.GCrypt (coreGCryptId) def :: [Command] def = [noCommit $ command "configlist" paramNothing seek @@ -21,5 +23,8 @@ seek = [withNothing start] start :: CommandStart start = do u <- getUUID - liftIO $ putStrLn $ "annex.uuid=" ++ fromUUID u + showConfig "annex.uuid" $ fromUUID u + showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "") stop + where + showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v diff --git a/Command/Copy.hs b/Command/Copy.hs index 4e1646ad1..9fd97334a 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -9,6 +9,7 @@ module Command.Copy where import Common.Annex import Command +import GitAnnex.Options import qualified Command.Move import qualified Remote import Annex.Wanted @@ -19,8 +20,8 @@ def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek seek :: [CommandSeek] seek = - [ withField Command.Move.toOption Remote.byNameWithUUID $ \to -> - withField Command.Move.fromOption Remote.byNameWithUUID $ \from -> + [ withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> withKeyOptions (Command.Move.startKey to from False) $ withFilesInGit $ whenAnnexed $ start to from ] diff --git a/Command/Direct.hs b/Command/Direct.hs index 7835988b4..1f262bd9f 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -7,6 +7,8 @@ module Command.Direct where +import Control.Exception.Extensible + import Common.Annex import Command import qualified Git @@ -15,6 +17,7 @@ import qualified Git.LsFiles import Config import Annex.Direct import Annex.Version +import Annex.Exception def :: [Command] def = [notBareRepo $ noDaemonRunning $ @@ -51,10 +54,17 @@ perform = do Nothing -> noop Just a -> do showStart "direct" f - a - showEndOk + r' <- tryAnnex a + case r' of + Left e -> warnlocked e + Right _ -> showEndOk return Nothing + warnlocked :: SomeException -> Annex () + warnlocked e = do + warning $ show e + warning "leaving this file as-is; correct this problem and run git annex fsck on it" + cleanup :: CommandCleanup cleanup = do showStart "direct" "" diff --git a/Command/Drop.hs b/Command/Drop.hs index b3f7d7574..5d642ed3a 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -139,7 +139,7 @@ notEnoughCopies key need have skip bad = do unsafe = showNote "unsafe" hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)" -{- In auto mode, only runs the action if there are enough copies +{- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. - - Passes any numcopies attribute of the file on to the action as an diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index ea606c284..f6a1b819c 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -43,12 +43,12 @@ unknownNameError prefix = do error $ prefix ++ if null names then "" - else " Known special remotes: " ++ intercalate " " names + else " Known special remotes: " ++ unwords names perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform perform t u c = do - c' <- R.setup t u c - next $ cleanup u c' + (c', u') <- R.setup t (Just u) c + next $ cleanup u' c' cleanup :: UUID -> R.RemoteConfig -> CommandCleanup cleanup u c = do diff --git a/Command/Fix.hs b/Command/Fix.hs index da2627619..a63a10f8f 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -14,9 +14,11 @@ import System.PosixCompat.Files import Common.Annex import Command import qualified Annex.Queue +#ifdef WITH_CLIBS #ifndef __ANDROID__ import Utility.Touch #endif +#endif def :: [Command] def = [notDirect $ noCommit $ command "fix" paramPaths seek @@ -36,17 +38,21 @@ start file (key, _) = do perform :: FilePath -> FilePath -> CommandPerform perform file link = do liftIO $ do +#ifdef WITH_CLIBS #ifndef __ANDROID__ -- preserve mtime of symlink mtime <- catchMaybeIO $ TimeSpec . modificationTime <$> getSymbolicLinkStatus file #endif +#endif createDirectoryIfMissing True (parentDir file) removeFile file createSymbolicLink link file +#ifdef WITH_CLIBS #ifndef __ANDROID__ maybe noop (\t -> touch file t False) mtime #endif +#endif next $ cleanup file cleanup :: FilePath -> CommandCleanup diff --git a/Command/Forget.hs b/Command/Forget.hs new file mode 100644 index 000000000..74bd68ad1 --- /dev/null +++ b/Command/Forget.hs @@ -0,0 +1,52 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Forget where + +import Common.Annex +import Command +import qualified Annex.Branch as Branch +import Logs.Transitions +import qualified Annex +import qualified Option + +import Data.Time.Clock.POSIX + +def :: [Command] +def = [withOptions forgetOptions $ command "forget" paramNothing seek + SectionMaintenance "prune git-annex branch history"] + +forgetOptions :: [Option] +forgetOptions = [dropDeadOption] + +dropDeadOption :: Option +dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories" + +seek :: [CommandSeek] +seek = [withFlag dropDeadOption $ \dropdead -> + withNothing $ start dropdead] + +start :: Bool -> CommandStart +start dropdead = do + showStart "forget" "git-annex" + now <- liftIO getPOSIXTime + let basets = addTransition now ForgetGitHistory noTransitions + let ts = if dropdead + then addTransition now ForgetDeadRemotes basets + else basets + next $ perform ts =<< Annex.getState Annex.force + +perform :: Transitions -> Bool -> CommandPerform +perform ts True = do + recordTransitions Branch.change ts + -- get branch committed before contining with the transition + Branch.update + void $ Branch.performTransitions ts True [] + next $ return True +perform _ False = do + showLongNote "To forget git-annex branch history, you must specify --force. This deletes metadata!" + stop diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 6464fc002..3b89c550c 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -33,7 +33,7 @@ import qualified Option import Types.Key import Utility.HumanTime import Git.FilePath -import GitAnnex.Options +import GitAnnex.Options hiding (fromOption) #ifndef mingw32_HOST_OS import System.Posix.Process (getProcessID) @@ -104,7 +104,7 @@ withIncremental = withValue $ do Nothing -> noop Just started -> do now <- liftIO getPOSIXTime - when (now - realToFrac started >= delta) $ + when (now - realToFrac started >= durationToPOSIXTime delta) resetStartTime return True @@ -187,7 +187,7 @@ performAll key backend = check ] check :: [Annex Bool] -> Annex Bool -check cs = all id <$> sequence cs +check cs = and <$> sequence cs {- Checks that the file's link points correctly to the content. - @@ -225,7 +225,7 @@ verifyLocationLog key desc = do {- In direct mode, modified files will show up as not present, - but that is expected and not something to do anything about. -} - if (direct && not present) + if direct && not present then return True else verifyLocationLog' key desc present u (logChange key u) @@ -271,7 +271,7 @@ verifyDirectMapping key file = do {- Ensures that files whose content is available are in direct mode. -} verifyDirectMode :: Key -> FilePath -> Annex Bool verifyDirectMode key file = do - whenM (isDirect <&&> islink) $ do + whenM (isDirect <&&> isJust <$> isAnnexLink file) $ do v <- toDirectGen key file case v of Nothing -> noop @@ -279,8 +279,6 @@ verifyDirectMode key file = do showNote "fixing direct mode" a return True - where - islink = liftIO $ isSymbolicLink <$> getSymbolicLinkStatus file {- The size of the data for a key is checked against the size encoded in - the key's metadata, if available. @@ -347,7 +345,7 @@ checkBackend backend key mfile = go =<< isDirect checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool checkBackendRemote backend key remote = maybe (return True) go where - go file = checkBackendOr (badContentRemote remote) backend key file + go = checkBackendOr (badContentRemote remote) backend key checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool checkBackendOr bad backend key file = @@ -408,7 +406,7 @@ badContentDirect :: FilePath -> Key -> Annex String badContentDirect file key = do void $ liftIO $ catchMaybeIO $ touchFile file logStatus key InfoMissing - return $ "left in place for you to examine" + return "left in place for you to examine" badContentRemote :: Remote -> Key -> Annex String badContentRemote remote key = do diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs new file mode 100644 index 000000000..bdd770f15 --- /dev/null +++ b/Command/GCryptSetup.hs @@ -0,0 +1,39 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.GCryptSetup where + +import Common.Annex +import Command +import Annex.UUID +import qualified Remote.GCrypt +import qualified Git + +def :: [Command] +def = [dontCheck repoExists $ noCommit $ + command "gcryptsetup" paramValue seek + SectionPlumbing "sets up gcrypt repository"] + +seek :: [CommandSeek] +seek = [withStrings start] + +start :: String -> CommandStart +start gcryptid = next $ next $ do + u <- getUUID + when (u /= NoUUID) $ + error "gcryptsetup refusing to run; this repository already has a git-annex uuid!" + + g <- gitRepo + gu <- Remote.GCrypt.getGCryptUUID True g + let newgu = genUUIDInNameSpace gCryptNameSpace gcryptid + if gu == Nothing || gu == Just newgu + then if Git.repoIsLocalBare g + then do + void $ Remote.GCrypt.setupRepo gcryptid g + return True + else error "cannot use gcrypt in a non-bare repository" + else error "gcryptsetup uuid mismatch" diff --git a/Command/Get.hs b/Command/Get.hs index 31a75c3e1..9adf79393 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -11,10 +11,10 @@ import Common.Annex import Command import qualified Remote import Annex.Content -import qualified Command.Move import Logs.Transfer import Annex.Wanted import GitAnnex.Options +import qualified Command.Move import Types.Key def :: [Command] @@ -22,11 +22,11 @@ def = [withOptions getOptions $ command "get" paramPaths seek SectionCommon "make content of annexed files available"] getOptions :: [Option] -getOptions = [Command.Move.fromOption] ++ keyOptions +getOptions = fromOption : keyOptions seek :: [CommandSeek] seek = - [ withField Command.Move.fromOption Remote.byNameWithUUID $ \from -> + [ withField fromOption Remote.byNameWithUUID $ \from -> withKeyOptions (startKeys from) $ withFilesInGit $ whenAnnexed $ start from ] @@ -75,7 +75,7 @@ getKeyFile key afile dest = dispatch =<< Remote.keyPossibilities key ( docopy r (trycopy full rs) , trycopy full rs ) - showlocs = Remote.showLocations key [] $ + showlocs = Remote.showLocations key [] "No other repository is known to contain the file." -- This check is to avoid an ugly message if a remote is a -- drive that is not mounted. diff --git a/Command/Import.hs b/Command/Import.hs index 518666af9..dcadd96ce 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2012-2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,30 +13,92 @@ import Common.Annex import Command import qualified Annex import qualified Command.Add +import qualified Option +import Utility.CopyFile +import Backend +import Remote +import Types.KeySource def :: [Command] -def = [notBareRepo $ command "import" paramPaths seek +def = [withOptions opts $ notBareRepo $ command "import" paramPaths seek SectionCommon "move and add files from outside git working copy"] +opts :: [Option] +opts = + [ duplicateOption + , deduplicateOption + , cleanDuplicatesOption + ] + +duplicateOption :: Option +duplicateOption = Option.flag [] "duplicate" "do not delete outside files" + +deduplicateOption :: Option +deduplicateOption = Option.flag [] "deduplicate" "do not add files whose content has been seen" + +cleanDuplicatesOption :: Option +cleanDuplicatesOption = Option.flag [] "clean-duplicates" "delete outside duplicate files (import nothing)" + +data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates + deriving (Eq) + +getDuplicateMode :: Annex DuplicateMode +getDuplicateMode = gen + <$> getflag duplicateOption + <*> getflag deduplicateOption + <*> getflag cleanDuplicatesOption + where + getflag = Annex.getFlag . Option.name + gen False False False = Default + gen True False False = Duplicate + gen False True False = DeDuplicate + gen False False True = CleanDuplicates + gen _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates" + seek :: [CommandSeek] -seek = [withPathContents start] +seek = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode] -start :: (FilePath, FilePath) -> CommandStart -start (srcfile, destfile) = +start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart +start mode (srcfile, destfile) = ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) ( do showStart "import" destfile - next $ perform srcfile destfile + next $ perform mode srcfile destfile , stop ) -perform :: FilePath -> FilePath -> CommandPerform -perform srcfile destfile = do - whenM (liftIO $ doesFileExist destfile) $ - unlessM (Annex.getState Annex.force) $ - error $ "not overwriting existing " ++ destfile ++ - " (use --force to override)" - - liftIO $ createDirectoryIfMissing True (parentDir destfile) - liftIO $ moveFile srcfile destfile - Command.Add.perform destfile +perform :: DuplicateMode -> FilePath -> FilePath -> CommandPerform +perform mode srcfile destfile = + case mode of + DeDuplicate -> ifM isdup + ( deletedup + , go + ) + CleanDuplicates -> ifM isdup + ( deletedup + , next $ return True + ) + _ -> go + where + isdup = do + backend <- chooseBackend destfile + let ks = KeySource srcfile srcfile Nothing + v <- genKey ks backend + case v of + Just (k, _) -> not . null <$> keyLocations k + _ -> return False + deletedup = do + showNote "duplicate" + liftIO $ removeFile srcfile + next $ return True + go = do + whenM (liftIO $ doesFileExist destfile) $ + unlessM (Annex.getState Annex.force) $ + error $ "not overwriting existing " ++ destfile ++ + " (use --force to override)" + + liftIO $ createDirectoryIfMissing True (parentDir destfile) + liftIO $ if mode == Duplicate + then void $ copyFileExternal srcfile destfile + else moveFile srcfile destfile + Command.Add.perform destfile diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 5ad568647..7f54643c9 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -12,13 +12,12 @@ import Text.Feed.Query import Text.Feed.Types import qualified Data.Set as S import qualified Data.Map as M -import Data.Char import Data.Time.Clock import Common.Annex import qualified Annex import Command -import qualified Utility.Url as Url +import qualified Annex.Url as Url import Logs.Web import qualified Option import qualified Utility.Format @@ -51,9 +50,10 @@ perform relaxed cache url = do v <- findEnclosures url case v of Just l | not (null l) -> do - ok <- all id - <$> mapM (downloadEnclosure relaxed cache) l - next $ cleanup url ok + ok <- and <$> mapM (downloadEnclosure relaxed cache) l + unless ok $ + feedProblem url "problem downloading item" + next $ cleanup url True _ -> do feedProblem url "bad feed content" next $ return True @@ -102,9 +102,10 @@ findEnclosures url = extract <$> downloadFeed url downloadFeed :: URLString -> Annex (Maybe Feed) downloadFeed url = do showOutput + ua <- Url.getUserAgent liftIO $ withTmpFile "feed" $ \f h -> do fileEncoding h - ifM (Url.download url [] [] f) + ifM (Url.download url [] [] f ua) ( liftIO $ parseFeedString <$> hGetContentsStrict h , return Nothing ) @@ -172,20 +173,15 @@ feedFile tmpl i = Utility.Format.format tmpl $ M.fromList , fieldMaybe "itemdescription" $ getItemDescription $ item i , fieldMaybe "itemrights" $ getItemRights $ item i , fieldMaybe "itemid" $ snd <$> getItemId (item i) - , ("extension", map sanitize $ takeExtension $ location i) + , ("extension", sanitizeFilePath $ takeExtension $ location i) ] where field k v = - let s = map sanitize v in + let s = sanitizeFilePath v in if null s then (k, "none") else (k, s) fieldMaybe k Nothing = (k, "none") fieldMaybe k (Just v) = field k v - sanitize c - | c == '.' = c - | isSpace c || isPunctuation c || c == '/' = '_' - | otherwise = c - {- Called when there is a problem with a feed. - Throws an error if the feed is broken, otherwise shows a warning. -} feedProblem :: URLString -> String -> Annex () diff --git a/Command/Indirect.hs b/Command/Indirect.hs index e63c4cb8a..a2512ea96 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -8,12 +8,14 @@ module Command.Indirect where import System.PosixCompat.Files +import Control.Exception.Extensible import Common.Annex import Command import qualified Git import qualified Git.Command import qualified Git.LsFiles +import Git.FileMode import Config import qualified Annex import Annex.Direct @@ -21,7 +23,9 @@ import Annex.Content import Annex.CatFile import Annex.Version import Annex.Perms +import Annex.Exception import Init +import qualified Command.Add def :: [Command] def = [notBareRepo $ noDaemonRunning $ @@ -45,7 +49,7 @@ start = ifM isDirect perform :: CommandPerform perform = do showStart "commit" "" - whenM (stageDirect) $ do + whenM stageDirect $ do showOutput void $ inRepo $ Git.Command.runBool [ Param "commit" @@ -67,8 +71,7 @@ perform = do {- Walk tree from top and move all present direct mode files into - the annex, replacing with symlinks. Also delete direct mode - caches and mappings. -} - go (_, Nothing) = noop - go (f, Just sha) = do + go (f, Just sha, Just mode) | isSymLink mode = do r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f case r of Just s @@ -78,23 +81,33 @@ perform = do return Nothing | otherwise -> maybe noop (fromdirect f) - =<< catKey sha + =<< catKey sha mode _ -> noop + go _ = noop fromdirect f k = do showStart "indirect" f thawContentDir =<< calcRepo (gitAnnexLocation k) cleandirect k -- clean before content directory gets frozen whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do - moveAnnex k f - l <- inRepo $ gitAnnexLink f k - liftIO $ createSymbolicLink l f + v <-tryAnnexIO (moveAnnex k f) + case v of + Right _ -> do + l <- inRepo $ gitAnnexLink f k + liftIO $ createSymbolicLink l f + Left e -> catchAnnex (Command.Add.undo f k e) + warnlocked showEndOk + warnlocked :: SomeException -> Annex () + warnlocked e = do + warning $ show e + warning "leaving this file as-is; correct this problem and run git annex add on it" + cleandirect k = do liftIO . nukeFile =<< calcRepo (gitAnnexInodeCache k) liftIO . nukeFile =<< calcRepo (gitAnnexMapping k) - + cleanup :: CommandCleanup cleanup = do setVersion defaultVersion diff --git a/Command/Info.hs b/Command/Info.hs new file mode 100644 index 000000000..d465f2d84 --- /dev/null +++ b/Command/Info.hs @@ -0,0 +1,384 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Command.Info where + +import "mtl" Control.Monad.State.Strict +import qualified Data.Map as M +import Text.JSON +import Data.Tuple +import Data.Ord +import System.PosixCompat.Files + +import Common.Annex +import qualified Remote +import qualified Command.Unused +import qualified Git +import qualified Annex +import Command +import Utility.DataUnits +import Utility.DiskFree +import Annex.Content +import Types.Key +import Logs.UUID +import Logs.Trust +import Remote +import Config +import Utility.Percentage +import Logs.Transfer +import Types.TrustLevel +import Types.FileMatcher +import qualified Limit + +-- a named computation that produces a statistic +type Stat = StatState (Maybe (String, StatState String)) + +-- data about a set of keys +data KeyData = KeyData + { countKeys :: Integer + , sizeKeys :: Integer + , unknownSizeKeys :: Integer + , backendsKeys :: M.Map String Integer + } + +data NumCopiesStats = NumCopiesStats + { numCopiesVarianceMap :: M.Map Variance Integer + } + +newtype Variance = Variance Int + deriving (Eq, Ord) + +instance Show Variance where + show (Variance n) + | n >= 0 = "numcopies +" ++ show n + | otherwise = "numcopies " ++ show n + +-- cached info that multiple Stats use +data StatInfo = StatInfo + { presentData :: Maybe KeyData + , referencedData :: Maybe KeyData + , numCopiesStats :: Maybe NumCopiesStats + } + +-- a state monad for running Stats in +type StatState = StateT StatInfo Annex + +def :: [Command] +def = [noCommit $ command "info" paramPaths seek + SectionQuery "shows general information about the annex"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [FilePath] -> CommandStart +start [] = do + globalInfo + stop +start ps = do + mapM_ localInfo =<< filterM isdir ps + stop + where + isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) + +globalInfo :: Annex () +globalInfo = do + stats <- selStats global_fast_stats global_slow_stats + showCustom "info" $ do + evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing) + return True + +localInfo :: FilePath -> Annex () +localInfo dir = showCustom (unwords ["info", dir]) $ do + stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats) + evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir + return True + where + tostats = map (\s -> s dir) + +selStats :: [Stat] -> [Stat] -> Annex [Stat] +selStats fast_stats slow_stats = do + fast <- Annex.getState Annex.fast + return $ if fast + then fast_stats + else fast_stats ++ slow_stats + +{- Order is significant. Less expensive operations, and operations + - that share data go together. + -} +global_fast_stats :: [Stat] +global_fast_stats = + [ repository_mode + , remote_list Trusted + , remote_list SemiTrusted + , remote_list UnTrusted + , transfer_list + , disk_size + ] +global_slow_stats :: [Stat] +global_slow_stats = + [ tmp_size + , bad_data_size + , local_annex_keys + , local_annex_size + , known_annex_files + , known_annex_size + , bloom_info + , backend_usage + ] +local_fast_stats :: [FilePath -> Stat] +local_fast_stats = + [ local_dir + , const local_annex_keys + , const local_annex_size + , const known_annex_files + , const known_annex_size + ] +local_slow_stats :: [FilePath -> Stat] +local_slow_stats = + [ const numcopies_stats + ] + +stat :: String -> (String -> StatState String) -> Stat +stat desc a = return $ Just (desc, a desc) + +nostat :: Stat +nostat = return Nothing + +json :: JSON j => (j -> String) -> StatState j -> String -> StatState String +json serialize a desc = do + j <- a + lift $ maybeShowJSON [(desc, j)] + return $ serialize j + +nojson :: StatState String -> String -> StatState String +nojson a _ = a + +showStat :: Stat -> StatState () +showStat s = maybe noop calc =<< s + where + calc (desc, a) = do + (lift . showHeader) desc + lift . showRaw =<< a + +repository_mode :: Stat +repository_mode = stat "repository mode" $ json id $ lift $ + ifM isDirect + ( return "direct", return "indirect" ) + +remote_list :: TrustLevel -> Stat +remote_list level = stat n $ nojson $ lift $ do + us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name) + rs <- fst <$> trustPartition level us + s <- prettyPrintUUIDs n rs + return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s + where + n = showTrustLevel level ++ " repositories" + +local_dir :: FilePath -> Stat +local_dir dir = stat "directory" $ json id $ return dir + +local_annex_keys :: Stat +local_annex_keys = stat "local annex keys" $ json show $ + countKeys <$> cachedPresentData + +local_annex_size :: Stat +local_annex_size = stat "local annex size" $ json id $ + showSizeKeys <$> cachedPresentData + +known_annex_files :: Stat +known_annex_files = stat "annexed files in working tree" $ json show $ + countKeys <$> cachedReferencedData + +known_annex_size :: Stat +known_annex_size = stat "size of annexed files in working tree" $ json id $ + showSizeKeys <$> cachedReferencedData + +tmp_size :: Stat +tmp_size = staleSize "temporary directory size" gitAnnexTmpDir + +bad_data_size :: Stat +bad_data_size = staleSize "bad keys size" gitAnnexBadDir + +bloom_info :: Stat +bloom_info = stat "bloom filter size" $ json id $ do + localkeys <- countKeys <$> cachedPresentData + capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity + let note = aside $ + if localkeys >= capacity + then "appears too small for this repository; adjust annex.bloomcapacity" + else showPercentage 1 (percentage capacity localkeys) ++ " full" + + -- Two bloom filters are used at the same time, so double the size + -- of one. + size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$> + lift Command.Unused.bloomBitsHashes + + return $ size ++ note + +transfer_list :: Stat +transfer_list = stat "transfers in progress" $ nojson $ lift $ do + uuidmap <- Remote.remoteMap id + ts <- getTransfers + return $ if null ts + then "none" + else multiLine $ + map (uncurry $ line uuidmap) $ sort ts + where + line uuidmap t i = unwords + [ showLcDirection (transferDirection t) ++ "ing" + , fromMaybe (key2file $ transferKey t) (associatedFile i) + , if transferDirection t == Upload then "to" else "from" + , maybe (fromUUID $ transferUUID t) Remote.name $ + M.lookup (transferUUID t) uuidmap + ] + +disk_size :: Stat +disk_size = stat "available local disk space" $ json id $ lift $ + calcfree + <$> (annexDiskReserve <$> Annex.getGitConfig) + <*> inRepo (getDiskFree . gitAnnexDir) + where + calcfree reserve (Just have) = unwords + [ roughSize storageUnits False $ nonneg $ have - reserve + , "(+" ++ roughSize storageUnits False reserve + , "reserved)" + ] + calcfree _ _ = "unknown" + + nonneg x + | x >= 0 = x + | otherwise = 0 + +backend_usage :: Stat +backend_usage = stat "backend usage" $ nojson $ + calc + <$> (backendsKeys <$> cachedReferencedData) + <*> (backendsKeys <$> cachedPresentData) + where + calc x y = multiLine $ + map (\(n, b) -> b ++ ": " ++ show n) $ + reverse $ sort $ map swap $ M.toList $ + M.unionWith (+) x y + +numcopies_stats :: Stat +numcopies_stats = stat "numcopies stats" $ nojson $ + calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats) + where + calc = multiLine + . map (\(variance, count) -> show variance ++ ": " ++ show count) + . reverse . sortBy (comparing snd) . M.toList + +cachedPresentData :: StatState KeyData +cachedPresentData = do + s <- get + case presentData s of + Just v -> return v + Nothing -> do + v <- foldKeys <$> lift getKeysPresent + put s { presentData = Just v } + return v + +cachedReferencedData :: StatState KeyData +cachedReferencedData = do + s <- get + case referencedData s of + Just v -> return v + Nothing -> do + !v <- lift $ Command.Unused.withKeysReferenced + emptyKeyData addKey + put s { referencedData = Just v } + return v + +-- currently only available for local info +cachedNumCopiesStats :: StatState (Maybe NumCopiesStats) +cachedNumCopiesStats = numCopiesStats <$> get + +getLocalStatInfo :: FilePath -> Annex StatInfo +getLocalStatInfo dir = do + fast <- Annex.getState Annex.fast + matcher <- Limit.getMatcher + (presentdata, referenceddata, numcopiesstats) <- + Command.Unused.withKeysFilesReferencedIn dir initial + (update matcher fast) + return $ StatInfo (Just presentdata) (Just referenceddata) (Just numcopiesstats) + where + initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats) + update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats) = + ifM (matcher $ FileInfo file file) + ( do + !presentdata' <- ifM (inAnnex key) + ( return $ addKey key presentdata + , return presentdata + ) + let !referenceddata' = addKey key referenceddata + !numcopiesstats' <- if fast + then return numcopiesstats + else updateNumCopiesStats key file numcopiesstats + return $! (presentdata', referenceddata', numcopiesstats') + , return vs + ) + +emptyKeyData :: KeyData +emptyKeyData = KeyData 0 0 0 M.empty + +emptyNumCopiesStats :: NumCopiesStats +emptyNumCopiesStats = NumCopiesStats M.empty + +foldKeys :: [Key] -> KeyData +foldKeys = foldl' (flip addKey) emptyKeyData + +addKey :: Key -> KeyData -> KeyData +addKey key (KeyData count size unknownsize backends) = + KeyData count' size' unknownsize' backends' + where + {- All calculations strict to avoid thunks when repeatedly + - applied to many keys. -} + !count' = count + 1 + !backends' = M.insertWith' (+) (keyBackendName key) 1 backends + !size' = maybe size (+ size) ks + !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks + ks = keySize key + +updateNumCopiesStats :: Key -> FilePath -> NumCopiesStats -> Annex NumCopiesStats +updateNumCopiesStats key file (NumCopiesStats m) = do + !variance <- Variance <$> numCopiesCheck file key (-) + let !m' = M.insertWith' (+) variance 1 m + let !ret = NumCopiesStats m' + return ret + +showSizeKeys :: KeyData -> String +showSizeKeys d = total ++ missingnote + where + total = roughSize storageUnits False $ sizeKeys d + missingnote + | unknownSizeKeys d == 0 = "" + | otherwise = aside $ + "+ " ++ show (unknownSizeKeys d) ++ + " unknown size" + +staleSize :: String -> (Git.Repo -> FilePath) -> Stat +staleSize label dirspec = go =<< lift (dirKeys dirspec) + where + go [] = nostat + go keys = onsize =<< sum <$> keysizes keys + onsize 0 = nostat + onsize size = stat label $ + json (++ aside "clean up with git-annex unused") $ + return $ roughSize storageUnits False size + keysizes keys = do + dir <- lift $ fromRepo dirspec + liftIO $ forM keys $ \k -> catchDefaultIO 0 $ + fromIntegral . fileSize + <$> getFileStatus (dir </> keyFile k) + +aside :: String -> String +aside s = " (" ++ s ++ ")" + +multiLine :: [String] -> String +multiLine = concatMap (\l -> "\n\t" ++ l) diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 684a2cc91..5a240f800 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -14,7 +14,6 @@ import Command import qualified Remote import qualified Logs.Remote import qualified Types.Remote as R -import Annex.UUID import Logs.UUID import Logs.Trust @@ -34,18 +33,18 @@ start (name:ws) = ifM (isJust <$> findExisting name) ( error $ "There is already a special remote named \"" ++ name ++ "\". (Use enableremote to enable an existing special remote.)" , do - (u, c) <- generateNew name + let c = newConfig name t <- findType config showStart "initremote" name - next $ perform t u name $ M.union config c + next $ perform t name $ M.union config c ) where config = Logs.Remote.keyValToConfig ws -perform :: RemoteType -> UUID -> String -> R.RemoteConfig -> CommandPerform -perform t u name c = do - c' <- R.setup t u c +perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform +perform t name c = do + (c', u) <- R.setup t Nothing c next $ cleanup u name c' cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup @@ -63,10 +62,8 @@ findExisting name = do <$> Logs.Remote.readRemoteLog return $ headMaybe matches -generateNew :: String -> Annex (UUID, R.RemoteConfig) -generateNew name = do - uuid <- liftIO genUUID - return (uuid, M.singleton nameKey name) +newConfig :: String -> R.RemoteConfig +newConfig name = M.singleton nameKey name findByName :: String -> M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)] findByName n = filter (matching . snd) . M.toList diff --git a/Command/List.hs b/Command/List.hs new file mode 100644 index 000000000..12c27c022 --- /dev/null +++ b/Command/List.hs @@ -0,0 +1,88 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - Copyright 2013 Antoine Beaupré + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.List where + +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Function +import Data.Tuple.Utils +import Data.Ord + +import Common.Annex +import Command +import Remote +import Logs.Trust +import Logs.UUID +import Annex.UUID +import qualified Option +import qualified Annex +import Git.Types (RemoteName) + +def :: [Command] +def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek + SectionQuery "show which remotes contain files"] + +allrepos :: Option +allrepos = Option.flag [] "allrepos" "show all repositories, not only remotes" + +seek :: [CommandSeek] +seek = + [ withValue getList $ withNothing . startHeader + , withValue getList $ withFilesInGit . whenAnnexed . start + ] + +getList :: Annex [(UUID, RemoteName, TrustLevel)] +getList = ifM (Annex.getFlag $ Option.name allrepos) + ( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAll) + , getRemotes + ) + where + getRemotes = do + rs <- remoteList + ts <- mapM (lookupTrust . uuid) rs + hereu <- getUUID + heretrust <- lookupTrust hereu + return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts + getAll = do + rs <- M.toList <$> uuidMap + rs3 <- forM rs $ \(u, n) -> (,,) + <$> pure u + <*> pure n + <*> lookupTrust u + return $ sortBy (comparing snd3) $ + filter (\t -> thd3 t /= DeadTrusted) rs3 + +startHeader :: [(UUID, RemoteName, TrustLevel)] -> CommandStart +startHeader l = do + liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l + stop + +start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart +start l file (key, _) = do + ls <- S.fromList <$> keyLocations key + liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file + stop + +type Present = Bool + +header :: [(RemoteName, TrustLevel)] -> String +header remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes) + where + formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel + pipes = flip replicate '|' + trust UnTrusted = " (untrusted)" + trust _ = "" + +format :: [(TrustLevel, Present)] -> FilePath -> String +format remotes file = thereMap ++ " " ++ file + where + thereMap = concatMap there remotes + there (UnTrusted, True) = "x" + there (_, True) = "X" + there (_, False) = "_" diff --git a/Command/Log.hs b/Command/Log.hs index 2d4819f7f..f3a5becb8 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -17,7 +17,7 @@ import Data.Char import Common.Annex import Command -import qualified Logs.Location +import Logs import qualified Logs.Presence import Annex.CatFile import qualified Annex.Branch @@ -135,7 +135,7 @@ getLog :: Key -> [CommandParam] -> Annex [String] getLog key os = do top <- fromRepo Git.repoPath p <- liftIO $ relPathCwdToFile top - let logfile = p </> Logs.Location.logFile key + let logfile = p </> locationLogFile key inRepo $ pipeNullSplitZombie $ [ Params "log -z --pretty=format:%ct --raw --abbrev=40" , Param "--remove-empty" diff --git a/Command/Map.hs b/Command/Map.hs index c88520b07..91f4a0251 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -20,7 +20,7 @@ import qualified Annex import Annex.UUID import Logs.UUID import Logs.Trust -import Remote.Helper.Ssh +import qualified Remote.Helper.Ssh as Ssh import qualified Utility.Dot as Dot -- a link from the first repository to the second (its remote) @@ -74,7 +74,7 @@ drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others hostname :: Git.Repo -> String hostname r - | Git.repoIsUrl r = Git.Url.host r + | Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r) | otherwise = "localhost" basehostname :: Git.Repo -> String @@ -203,9 +203,9 @@ tryScan r where p = proc cmd $ toCommand params - configlist = onRemote r (pipedconfig, Nothing) "configlist" [] [] + configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] [] manualconfiglist = do - sshparams <- sshToRepo r [Param sshcmd] + sshparams <- Ssh.toRepo r [Param sshcmd] liftIO $ pipedconfig "ssh" sshparams where sshcmd = cddir ++ " && " ++ diff --git a/Command/Merge.hs b/Command/Merge.hs index 659f14080..31db7a99f 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -11,7 +11,7 @@ import Common.Annex import Command import qualified Annex.Branch import qualified Git.Branch -import Command.Sync (mergeLocal) +import Command.Sync (prepMerge, mergeLocal) def :: [Command] def = [command "merge" paramNothing seek SectionMaintenance @@ -34,5 +34,5 @@ mergeBranch = do mergeSynced :: CommandStart mergeSynced = do - branch <- inRepo Git.Branch.current - maybe stop mergeLocal branch + prepMerge + mergeLocal =<< inRepo Git.Branch.current diff --git a/Command/Mirror.hs b/Command/Mirror.hs new file mode 100644 index 000000000..c0dd8a51f --- /dev/null +++ b/Command/Mirror.hs @@ -0,0 +1,58 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Mirror where + +import Common.Annex +import Command +import GitAnnex.Options +import qualified Command.Move +import qualified Command.Drop +import qualified Command.Get +import qualified Remote +import Annex.Content +import qualified Annex + +def :: [Command] +def = [withOptions fromToOptions $ command "mirror" paramPaths seek + SectionCommon "mirror content of files to/from another repository"] + +seek :: [CommandSeek] +seek = + [ withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> + withFilesInGit $ whenAnnexed $ start to from + ] + +start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start to from file (key, _backend) = do + noAuto + case (from, to) of + (Nothing, Nothing) -> error "specify either --from or --to" + (Nothing, Just r) -> mirrorto r + (Just r, Nothing) -> mirrorfrom r + _ -> error "only one of --from or --to can be specified" + where + noAuto = whenM (Annex.getState Annex.auto) $ + error "--auto is not supported for mirror" + mirrorto r = ifM (inAnnex key) + ( Command.Move.toStart r False (Just file) key + , do + numcopies <- numCopies file + Command.Drop.startRemote file numcopies key r + ) + mirrorfrom r = do + haskey <- Remote.hasKey r key + case haskey of + Left _ -> stop + Right True -> Command.Get.start' (return True) Nothing key (Just file) + Right False -> ifM (inAnnex key) + ( do + numcopies <- numCopies file + Command.Drop.startLocal file numcopies key Nothing + , stop + ) diff --git a/Command/Move.hs b/Command/Move.hs index 357ccc21e..dc501ae0f 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -14,7 +14,6 @@ import qualified Annex import Annex.Content import qualified Remote import Annex.UUID -import qualified Option import Logs.Presence import Logs.Transfer import GitAnnex.Options @@ -24,14 +23,8 @@ def :: [Command] def = [withOptions moveOptions $ command "move" paramPaths seek SectionCommon "move content of files to/from another repository"] -fromOption :: Option -fromOption = Option.field ['f'] "from" paramRemote "source remote" - -toOption :: Option -toOption = Option.field ['t'] "to" paramRemote "destination remote" - moveOptions :: [Option] -moveOptions = [fromOption, toOption] ++ keyOptions +moveOptions = fromToOptions ++ keyOptions seek :: [CommandSeek] seek = @@ -45,7 +38,7 @@ start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> C start to from move file (key, _) = start' to from move (Just file) key startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart -startKey to from move key = start' to from move Nothing key +startKey to from move = start' to from move Nothing start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart start' to from move afile key = do @@ -54,7 +47,7 @@ start' to from move afile key = do (Nothing, Nothing) -> error "specify either --from or --to" (Nothing, Just dest) -> toStart dest move afile key (Just src, Nothing) -> fromStart src move afile key - (_ , _) -> error "only one of --from or --to can be specified" + _ -> error "only one of --from or --to can be specified" where noAuto = when move $ whenM (Annex.getState Annex.auto) $ error "--auto is not supported for move" diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index 565344d25..f10ac628e 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -12,9 +12,11 @@ import Command import qualified Command.Add import qualified Command.Fix import qualified Git.DiffTree +import qualified Git.Ref import Annex.CatFile import Annex.Content.Direct import Git.Sha +import Git.FilePath def :: [Command] def = [command "pre-commit" paramPaths seek SectionPlumbing @@ -23,7 +25,7 @@ def = [command "pre-commit" paramPaths seek SectionPlumbing seek :: [CommandSeek] seek = -- fix symlinks to files being committed - [ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed $ Command.Fix.start + [ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed Command.Fix.start -- inject unlocked files into the annex , whenNotDirect $ withFilesUnlockedToBeCommitted startIndirect -- update direct mode mappings for committed files @@ -38,16 +40,18 @@ startIndirect file = next $ do startDirect :: [String] -> CommandStart startDirect _ = next $ do - (diffs, clean) <- inRepo $ Git.DiffTree.diffIndex - forM_ diffs go + (diffs, clean) <- inRepo $ Git.DiffTree.diffIndex Git.Ref.headRef + makeabs <- flip fromTopFilePath <$> gitRepo + forM_ diffs (go makeabs) next $ liftIO clean where - go diff = do - withkey (Git.DiffTree.srcsha diff) removeAssociatedFile - withkey (Git.DiffTree.dstsha diff) addAssociatedFile + go makeabs diff = do + withkey (Git.DiffTree.srcsha diff) (Git.DiffTree.srcmode diff) removeAssociatedFile + withkey (Git.DiffTree.dstsha diff) (Git.DiffTree.dstmode diff) addAssociatedFile where - withkey sha a = when (sha /= nullSha) $ do - k <- catKey sha + withkey sha mode a = when (sha /= nullSha) $ do + k <- catKey sha mode case k of Nothing -> noop - Just key -> void $ a key (Git.DiffTree.file diff) + Just key -> void $ a key $ + makeabs $ Git.DiffTree.file diff diff --git a/Command/ReKey.hs b/Command/ReKey.hs index d7b277fa6..7448ba97e 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -66,6 +66,6 @@ cleanup file oldkey newkey = do -- Update symlink to use the new key. liftIO $ removeFile file - Command.Add.addLink file newkey True + Command.Add.addLink file newkey Nothing logStatus newkey InfoPresent return True diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index c316e2ca5..3b2a8c496 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -32,7 +32,7 @@ seek = [withKeys start] start :: Key -> CommandStart start key = ifM (inAnnex key) ( error "key is already present in annex" - , fieldTransfer Download key $ \_p -> do + , fieldTransfer Download key $ \_p -> ifM (getViaTmp key go) ( do -- forcibly quit after receiving one key, @@ -72,7 +72,18 @@ start key = ifM (inAnnex key) return $ size == size' if oksize then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of - Nothing -> return False - Just backend -> maybe (return True) (\a -> a key tmp) + Nothing -> do + warning "recvkey: received key from direct mode repository using unknown backend; cannot check; discarding" + return False + Just backend -> maybe (return True) runfsck (Types.Backend.fsckKey backend) - else return False + else do + warning "recvkey: received key with wrong size; discarding" + return False + where + runfsck check = ifM (check key tmp) + ( return True + , do + warning "recvkey: received key from direct mode repository seems to have changed as it was transferred; discarding" + return False + ) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 642f38947..e4abeef3c 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -34,7 +34,7 @@ start (src:dest:[]) start _ = error "specify a src file and a dest file" perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform -perform src _dest (key, backend) = do +perform src _dest (key, backend) = {- Check the content before accepting it. -} ifM (Command.Fsck.checkKeySizeOr reject key src <&&> Command.Fsck.checkBackendOr reject backend key src) diff --git a/Command/Repair.hs b/Command/Repair.hs new file mode 100644 index 000000000..517e14afc --- /dev/null +++ b/Command/Repair.hs @@ -0,0 +1,71 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Repair where + +import Common.Annex +import Command +import qualified Annex +import qualified Git.Repair +import qualified Annex.Branch +import Git.Fsck (MissingObjects) +import Git.Types +import Annex.Version + +def :: [Command] +def = [noCommit $ dontCheck repoExists $ + command "repair" paramNothing seek SectionMaintenance "recover broken git repository"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = next $ next $ runRepair =<< Annex.getState Annex.force + +runRepair :: Bool -> Annex Bool +runRepair forced = do + (ok, stillmissing, modifiedbranches) <- inRepo $ + Git.Repair.runRepair forced + -- This command can be run in git repos not using git-annex, + -- so avoid git annex branch stuff in that case. + whenM (isJust <$> getVersion) $ + repairAnnexBranch stillmissing modifiedbranches + return ok + +{- After git repository repair, the .git/annex/index file could + - still be broken, by pointing to bad objects, or might just be corrupt on + - its own. Since this index file is not used to stage things + - for long durations of time, it can safely be deleted if it is broken. + - + - Otherwise, if the git-annex branch was modified by the repair, + - commit the index file to the git-annex branch. + - This way, if the git-annex branch got rewound to an old version by + - the repository repair, or was completely deleted, this will get it back + - to a good state. Note that in the unlikely case where the git-annex + - branch was rewound to a state that, had new changes from elsewhere not + - yet reflected in the index, this does properly merge those into the + - index before committing. + -} +repairAnnexBranch :: MissingObjects -> [Branch] -> Annex () +repairAnnexBranch missing modifiedbranches + | Annex.Branch.fullname `elem` modifiedbranches = ifM okindex + ( commitindex + , do + nukeindex + liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt. Since the git-annex branch is not up-to-date anymore. It would be a very good idea to run: git annex fsck --fast" + ) + | otherwise = ifM okindex + ( noop + , nukeindex + ) + where + okindex = Annex.Branch.withIndex $ + inRepo $ Git.Repair.checkIndex missing + commitindex = do + Annex.Branch.forceCommit "committing index after git repository repair" + liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index" + nukeindex = inRepo $ nukeFile . gitAnnexIndex diff --git a/Command/Schedule.hs b/Command/Schedule.hs new file mode 100644 index 000000000..35f144c75 --- /dev/null +++ b/Command/Schedule.hs @@ -0,0 +1,50 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Schedule where + +import Common.Annex +import Command +import qualified Remote +import Logs.Schedule +import Types.ScheduledActivity + +import qualified Data.Set as S + +def :: [Command] +def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek + SectionSetup "get or set scheduled jobs"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start = parse + where + parse (name:[]) = go name performGet + parse (name:expr:[]) = go name $ \uuid -> do + showStart "schedile" name + performSet expr uuid + parse _ = error "Specify a repository." + + go name a = do + u <- Remote.nameToUUID name + next $ a u + +performGet :: UUID -> CommandPerform +performGet uuid = do + s <- scheduleGet uuid + liftIO $ putStrLn $ intercalate "; " $ + map fromScheduledActivity $ S.toList s + next $ return True + +performSet :: String -> UUID -> CommandPerform +performSet expr uuid = case parseScheduledActivities expr of + Left e -> error $ "Parse error: " ++ e + Right l -> do + scheduleSet uuid l + next $ return True diff --git a/Command/SendKey.hs b/Command/SendKey.hs index afd1ac1e0..039a3d7ca 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -46,6 +46,6 @@ fieldTransfer direction key a = do ok <- maybe (a $ const noop) (\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a) =<< Fields.getField Fields.remoteUUID - if ok - then liftIO exitSuccess - else liftIO exitFailure + liftIO $ if ok + then exitSuccess + else exitFailure diff --git a/Command/Status.hs b/Command/Status.hs index af85fcc2a..5dc625994 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -1,345 +1,89 @@ {- git-annex command - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Command.Status where -import "mtl" Control.Monad.State.Strict -import qualified Data.Map as M -import Text.JSON -import Data.Tuple -import System.PosixCompat.Files - import Common.Annex -import qualified Types.Backend as B -import qualified Types.Remote as R -import qualified Remote -import qualified Command.Unused -import qualified Git -import qualified Annex import Command -import Utility.DataUnits -import Utility.DiskFree -import Annex.Content -import Types.Key -import Backend -import Logs.UUID -import Logs.Trust -import Remote +import Annex.CatFile +import Annex.Content.Direct import Config -import Utility.Percentage -import Logs.Transfer -import Types.TrustLevel -import Types.FileMatcher -import qualified Limit - --- a named computation that produces a statistic -type Stat = StatState (Maybe (String, StatState String)) - --- data about a set of keys -data KeyData = KeyData - { countKeys :: Integer - , sizeKeys :: Integer - , unknownSizeKeys :: Integer - , backendsKeys :: M.Map String Integer - } - --- cached info that multiple Stats use -data StatInfo = StatInfo - { presentData :: Maybe KeyData - , referencedData :: Maybe KeyData - } - --- a state monad for running Stats in -type StatState = StateT StatInfo Annex +import qualified Git.LsFiles as LsFiles +import qualified Git.Ref +import qualified Git def :: [Command] -def = [command "status" paramPaths seek - SectionQuery "shows status information about the annex"] +def = [notBareRepo $ noCommit $ noMessages $ + command "status" paramPaths seek SectionCommon + "show the working tree status"] seek :: [CommandSeek] -seek = [withWords start] +seek = + [ withWords start + ] start :: [FilePath] -> CommandStart start [] = do - globalStatus - stop -start ps = do - mapM_ localStatus =<< filterM isdir ps - stop - where - isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) - -globalStatus :: Annex () -globalStatus = do - fast <- Annex.getState Annex.fast - let stats = if fast - then global_fast_stats - else global_fast_stats ++ global_slow_stats - showCustom "status" $ do - evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing) - return True - -localStatus :: FilePath -> Annex () -localStatus dir = showCustom (unwords ["status", dir]) $ do - let stats = map (\s -> s dir) local_stats - evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir - return True - -{- Order is significant. Less expensive operations, and operations - - that share data go together. - -} -global_fast_stats :: [Stat] -global_fast_stats = - [ supported_backends - , supported_remote_types - , repository_mode - , remote_list Trusted - , remote_list SemiTrusted - , remote_list UnTrusted - , transfer_list - , disk_size - ] -global_slow_stats :: [Stat] -global_slow_stats = - [ tmp_size - , bad_data_size - , local_annex_keys - , local_annex_size - , known_annex_keys - , known_annex_size - , bloom_info - , backend_usage - ] -local_stats :: [FilePath -> Stat] -local_stats = - [ local_dir - , const local_annex_keys - , const local_annex_size - , const known_annex_keys - , const known_annex_size - ] - -stat :: String -> (String -> StatState String) -> Stat -stat desc a = return $ Just (desc, a desc) - -nostat :: Stat -nostat = return Nothing - -json :: JSON j => (j -> String) -> StatState j -> String -> StatState String -json serialize a desc = do - j <- a - lift $ maybeShowJSON [(desc, j)] - return $ serialize j - -nojson :: StatState String -> String -> StatState String -nojson a _ = a - -showStat :: Stat -> StatState () -showStat s = maybe noop calc =<< s - where - calc (desc, a) = do - (lift . showHeader) desc - lift . showRaw =<< a - -supported_backends :: Stat -supported_backends = stat "supported backends" $ json unwords $ - return $ map B.name Backend.list - -supported_remote_types :: Stat -supported_remote_types = stat "supported remote types" $ json unwords $ - return $ map R.typename Remote.remoteTypes - -repository_mode :: Stat -repository_mode = stat "repository mode" $ json id $ lift $ - ifM isDirect - ( return "direct", return "indirect" ) - -remote_list :: TrustLevel -> Stat -remote_list level = stat n $ nojson $ lift $ do - us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap Remote.name) - rs <- fst <$> trustPartition level us - s <- prettyPrintUUIDs n rs - return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s - where - n = showTrustLevel level ++ " repositories" + -- Like git status, when run without a directory, behave as if + -- given the path to the top of the repository. + cwd <- liftIO getCurrentDirectory + top <- fromRepo Git.repoPath + next $ perform [relPathDirToFile cwd top] +start locs = next $ perform locs -local_dir :: FilePath -> Stat -local_dir dir = stat "directory" $ json id $ return dir - -local_annex_size :: Stat -local_annex_size = stat "local annex size" $ json id $ - showSizeKeys <$> cachedPresentData - -local_annex_keys :: Stat -local_annex_keys = stat "local annex keys" $ json show $ - countKeys <$> cachedPresentData - -known_annex_size :: Stat -known_annex_size = stat "known annex size" $ json id $ - showSizeKeys <$> cachedReferencedData - -known_annex_keys :: Stat -known_annex_keys = stat "known annex keys" $ json show $ - countKeys <$> cachedReferencedData - -tmp_size :: Stat -tmp_size = staleSize "temporary directory size" gitAnnexTmpDir - -bad_data_size :: Stat -bad_data_size = staleSize "bad keys size" gitAnnexBadDir - -bloom_info :: Stat -bloom_info = stat "bloom filter size" $ json id $ do - localkeys <- countKeys <$> cachedPresentData - capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity - let note = aside $ - if localkeys >= capacity - then "appears too small for this repository; adjust annex.bloomcapacity" - else showPercentage 1 (percentage capacity localkeys) ++ " full" - - -- Two bloom filters are used at the same time, so double the size - -- of one. - size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$> - lift Command.Unused.bloomBitsHashes - - return $ size ++ note - -transfer_list :: Stat -transfer_list = stat "transfers in progress" $ nojson $ lift $ do - uuidmap <- Remote.remoteMap id - ts <- getTransfers - if null ts - then return "none" - else return $ multiLine $ - map (\(t, i) -> line uuidmap t i) $ sort ts - where - line uuidmap t i = unwords - [ showLcDirection (transferDirection t) ++ "ing" - , fromMaybe (key2file $ transferKey t) (associatedFile i) - , if transferDirection t == Upload then "to" else "from" - , maybe (fromUUID $ transferUUID t) Remote.name $ - M.lookup (transferUUID t) uuidmap - ] - -disk_size :: Stat -disk_size = stat "available local disk space" $ json id $ lift $ - calcfree - <$> (annexDiskReserve <$> Annex.getGitConfig) - <*> inRepo (getDiskFree . gitAnnexDir) - where - calcfree reserve (Just have) = unwords - [ roughSize storageUnits False $ nonneg $ have - reserve - , "(+" ++ roughSize storageUnits False reserve - , "reserved)" - ] - calcfree _ _ = "unknown" - - nonneg x - | x >= 0 = x - | otherwise = 0 - -backend_usage :: Stat -backend_usage = stat "backend usage" $ nojson $ - calc - <$> (backendsKeys <$> cachedReferencedData) - <*> (backendsKeys <$> cachedPresentData) - where - calc x y = multiLine $ - map (\(n, b) -> b ++ ": " ++ show n) $ - reverse $ sort $ map swap $ M.toList $ - M.unionWith (+) x y - -cachedPresentData :: StatState KeyData -cachedPresentData = do - s <- get - case presentData s of - Just v -> return v - Nothing -> do - v <- foldKeys <$> lift getKeysPresent - put s { presentData = Just v } - return v - -cachedReferencedData :: StatState KeyData -cachedReferencedData = do - s <- get - case referencedData s of - Just v -> return v - Nothing -> do - !v <- lift $ Command.Unused.withKeysReferenced - emptyKeyData addKey - put s { referencedData = Just v } - return v - -getLocalStatInfo :: FilePath -> Annex StatInfo -getLocalStatInfo dir = do - matcher <- Limit.getMatcher - (presentdata, referenceddata) <- - Command.Unused.withKeysFilesReferencedIn dir initial - (update matcher) - return $ StatInfo (Just presentdata) (Just referenceddata) - where - initial = (emptyKeyData, emptyKeyData) - update matcher key file vs@(presentdata, referenceddata) = - ifM (matcher $ FileInfo file file) - ( (,) - <$> ifM (inAnnex key) - ( return $ addKey key presentdata - , return presentdata - ) - <*> pure (addKey key referenceddata) - , return vs - ) - -emptyKeyData :: KeyData -emptyKeyData = KeyData 0 0 0 M.empty - -foldKeys :: [Key] -> KeyData -foldKeys = foldl' (flip addKey) emptyKeyData - -addKey :: Key -> KeyData -> KeyData -addKey key (KeyData count size unknownsize backends) = - KeyData count' size' unknownsize' backends' - where - {- All calculations strict to avoid thunks when repeatedly - - applied to many keys. -} - !count' = count + 1 - !backends' = M.insertWith' (+) (keyBackendName key) 1 backends - !size' = maybe size (+ size) ks - !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks - ks = keySize key - -showSizeKeys :: KeyData -> String -showSizeKeys d = total ++ missingnote +perform :: [FilePath] -> CommandPerform +perform locs = do + (l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs + getstatus <- ifM isDirect + ( return statusDirect + , return $ Just <$$> statusIndirect + ) + forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f + void $ liftIO cleanup + next $ return True + +data Status + = NewFile + | DeletedFile + | ModifiedFile + +showStatus :: Status -> String +showStatus NewFile = "?" +showStatus DeletedFile = "D" +showStatus ModifiedFile = "M" + +showFileStatus :: FilePath -> Status -> Annex () +showFileStatus f s = liftIO $ putStrLn $ showStatus s ++ " " ++ f + +statusDirect :: FilePath -> Annex (Maybe Status) +statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f) where - total = roughSize storageUnits False $ sizeKeys d - missingnote - | unknownSizeKeys d == 0 = "" - | otherwise = aside $ - "+ " ++ show (unknownSizeKeys d) ++ - " keys of unknown size" - -staleSize :: String -> (Git.Repo -> FilePath) -> Stat -staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec) + checkstatus Nothing = return $ Just DeletedFile + checkstatus (Just s) + -- Git thinks that present direct mode files modifed, + -- so have to check. + | not (isSymbolicLink s) = checkkey s =<< catKeyFile f + | otherwise = Just <$> checkNew f + + checkkey s (Just k) = ifM (sameFileStatus k s) + ( return Nothing + , return $ Just ModifiedFile + ) + checkkey _ Nothing = Just <$> checkNew f + +statusIndirect :: FilePath -> Annex Status +statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f)) + ( checkNew f + , return DeletedFile + ) where - go [] = nostat - go keys = onsize =<< sum <$> keysizes keys - onsize 0 = nostat - onsize size = stat label $ - json (++ aside "clean up with git-annex unused") $ - return $ roughSize storageUnits False size - keysizes keys = map (fromIntegral . fileSize) <$> stats keys - stats keys = do - dir <- lift $ fromRepo dirspec - liftIO $ forM keys $ \k -> getFileStatus (dir </> keyFile k) - -aside :: String -> String -aside s = " (" ++ s ++ ")" -multiLine :: [String] -> String -multiLine = concatMap (\l -> "\n\t" ++ l) +checkNew :: FilePath -> Annex Status +checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f)) + ( return ModifiedFile + , return NewFile + ) diff --git a/Command/Sync.hs b/Command/Sync.hs index a6ae610f8..c41f46f8a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -29,8 +29,11 @@ import qualified Remote.Git import Types.Key import Config import Annex.ReplaceFile +import Git.FileMode +import qualified Data.Set as S import Data.Hash.MD5 +import Control.Concurrent.MVar def :: [Command] def = [command "sync" (paramOptional (paramRepeating paramRemote)) @@ -39,24 +42,43 @@ def = [command "sync" (paramOptional (paramRepeating paramRemote)) -- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do - branch <- fromMaybe nobranch <$> inRepo Git.Branch.current + prepMerge + + -- There may not be a branch checked out until after the commit, + -- or perhaps after it gets merged from the remote. + -- So only look it up once it's needed, and if once there is a + -- branch, cache it. + mvar <- liftIO newEmptyMVar + let getbranch = ifM (liftIO $ isEmptyMVar mvar) + ( do + branch <- inRepo Git.Branch.current + when (isJust branch) $ + liftIO $ putMVar mvar branch + return branch + , liftIO $ readMVar mvar + ) + let withbranch a = a =<< getbranch + remotes <- syncRemotes rs return $ concat [ [ commit ] - , [ mergeLocal branch ] - , [ pullRemote remote branch | remote <- remotes ] + , [ withbranch mergeLocal ] + , [ withbranch (pullRemote remote) | remote <- remotes ] , [ mergeAnnex ] - , [ pushLocal branch ] - , [ pushRemote remote branch | remote <- remotes ] + , [ withbranch pushLocal ] + , [ withbranch (pushRemote remote) | remote <- remotes ] ] - where - nobranch = error "no branch is checked out" + +{- Merging may delete the current directory, so go to the top + - of the repo. -} +prepMerge :: Annex () +prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath syncBranch :: Git.Ref -> Git.Ref -syncBranch = Git.Ref.under "refs/heads/synced/" +syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch remoteBranch :: Remote -> Git.Ref -> Git.Ref -remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote +remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote syncRemotes :: [String] -> Annex [Remote] syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) @@ -67,52 +89,62 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) | otherwise = listed listed = do l <- catMaybes <$> mapM (Remote.byName . Just) rs - let s = filter Remote.specialRemote l + let s = filter (not . Remote.syncableRemote) l unless (null s) $ error $ "cannot sync special remotes: " ++ unwords (map Types.Remote.name s) return l - available = filter (not . Remote.specialRemote) + available = filter Remote.syncableRemote . filter (remoteAnnexSync . Types.Remote.gitconfig) <$> Remote.remoteList good = filterM $ Remote.Git.repoAvail . Types.Remote.repo fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: CommandStart -commit = next $ next $ do - ifM isDirect - ( do - void $ stageDirect - runcommit [] - , runcommit [Param "-a"] - ) +commit = next $ next $ ifM isDirect + ( do + void stageDirect + runcommit [] + , runcommit [Param "-a"] + ) where runcommit ps = do showStart "commit" "" showOutput Annex.Branch.commit "update" -- Commit will fail when the tree is clean, so ignore failure. - let params = (Param "commit") : ps ++ + let params = Param "commit" : ps ++ [Param "-m", Param "git-annex automatic sync"] _ <- inRepo $ tryIO . Git.Command.runQuiet params return True -mergeLocal :: Git.Ref -> CommandStart -mergeLocal branch = go =<< needmerge +mergeLocal :: Maybe Git.Ref -> CommandStart +mergeLocal Nothing = stop +mergeLocal (Just branch) = go =<< needmerge where syncbranch = syncBranch branch - needmerge = do - unlessM (inRepo $ Git.Ref.exists syncbranch) $ - inRepo $ updateBranch syncbranch - inRepo $ Git.Branch.changed branch syncbranch + needmerge = ifM isBareRepo + ( return False + , do + unlessM (inRepo $ Git.Ref.exists syncbranch) $ + inRepo $ updateBranch syncbranch + inRepo $ Git.Branch.changed branch syncbranch + ) go False = stop go True = do showStart "merge" $ Git.Ref.describe syncbranch next $ next $ mergeFrom syncbranch -pushLocal :: Git.Ref -> CommandStart -pushLocal branch = do +pushLocal :: Maybe Git.Ref -> CommandStart +pushLocal Nothing = stop +pushLocal (Just branch) = do + -- Update the sync branch to match the new state of the branch inRepo $ updateBranch $ syncBranch branch + -- In direct mode, we're operating on some special direct mode + -- branch, rather than the intended branch, so update the indended + -- branch. + whenM isDirect $ + inRepo $ updateBranch $ fromDirectBranch branch stop updateBranch :: Git.Ref -> Git.Repo -> IO () @@ -125,13 +157,13 @@ updateBranch syncbranch g = , Param $ show $ Git.Ref.base syncbranch ] g -pullRemote :: Remote -> Git.Ref -> CommandStart +pullRemote :: Remote -> Maybe Git.Ref -> CommandStart pullRemote remote branch = do showStart "pull" (Remote.name remote) next $ do showOutput stopUnless fetch $ - next $ mergeRemote remote (Just branch) + next $ mergeRemote remote branch where fetch = inRepo $ Git.Command.runBool [Param "fetch", Param $ Remote.name remote] @@ -141,20 +173,21 @@ pullRemote remote branch = do - were committed (or pushed changes, if this is a bare remote), - while the synced/master may have changes that some - other remote synced to this remote. So, merge them both. -} -mergeRemote :: Remote -> (Maybe Git.Ref) -> CommandCleanup +mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup mergeRemote remote b = case b of Nothing -> do branch <- inRepo Git.Branch.currentUnsafe - all id <$> (mapM merge $ branchlist branch) - Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b)) + and <$> mapM merge (branchlist branch) + Just _ -> and <$> (mapM merge =<< tomerge (branchlist b)) where merge = mergeFrom . remoteBranch remote tomerge branches = filterM (changed remote) branches branchlist Nothing = [] branchlist (Just branch) = [branch, syncBranch branch] -pushRemote :: Remote -> Git.Ref -> CommandStart -pushRemote remote branch = go =<< needpush +pushRemote :: Remote -> Maybe Git.Ref -> CommandStart +pushRemote _remote Nothing = stop +pushRemote remote (Just branch) = go =<< needpush where needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name] go False = stop @@ -162,31 +195,54 @@ pushRemote remote branch = go =<< needpush showStart "push" (Remote.name remote) next $ next $ do showOutput - inRepo $ pushBranch remote branch + ok <- inRepo $ pushBranch remote branch + unless ok $ do + warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] + showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)" + return ok -{- If the remote is a bare git repository, it's best to push the branch - - directly to it. On the other hand, if it's not bare, pushing to the - - checked out branch will fail, and this is why we use the syncBranch. +{- Pushes a regular branch like master to a remote. Also pushes the git-annex + - branch. + - + - If the remote is a bare git repository, it's best to push the regular + - branch directly to it, so that cloning/pulling will get it. + - On the other hand, if it's not bare, pushing to the checked out branch + - will fail, and this is why we push to its syncBranch. - - Git offers no way to tell if a remote is bare or not, so both methods - are tried. - - The direct push is likely to spew an ugly error message, so stderr is - - elided. Since progress is output to stderr too, the sync push is done - - first, and actually sends the data. Then the direct push is tried, - - with stderr discarded, to update the branch ref on the remote. + - elided. Since git progress display goes to stderr too, the sync push + - is done first, and actually sends the data. Then the direct push is + - tried, with stderr discarded, to update the branch ref on the remote. + - + - The sync push forces the update of the remote synced/git-annex branch. + - This is necessary if a transition has rewritten the git-annex branch. + - Normally any changes to the git-annex branch get pulled and merged before + - this push, so this forcing is unlikely to overwrite new data pushed + - in from another repository that is also syncing. + - + - But overwriting of data on synced/git-annex can happen, in a race. + - The only difference caused by using a forced push in that case is that + - the last repository to push wins the race, rather than the first to push. + - + - The sync push will fail to overwrite if receive.denyNonFastforwards is + - set on the remote. -} pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool -pushBranch remote branch g = tryIO directpush `after` syncpush +pushBranch remote branch g = tryIO (directpush g) `after` syncpush g where - syncpush = Git.Command.runBool (pushparams (refspec branch)) g - directpush = Git.Command.runQuiet (pushparams (show $ Git.Ref.base branch)) g - pushparams b = + syncpush = Git.Command.runBool $ pushparams + [ Git.Branch.forcePush $ refspec Annex.Branch.name + , refspec branch + ] + directpush = Git.Command.runQuiet $ pushparams + [show $ Git.Ref.base $ fromDirectBranch branch] + pushparams branches = [ Param "push" , Param $ Remote.name remote - , Param $ refspec Annex.Branch.name - , Param b - ] + ] ++ map Param branches refspec b = concat [ show $ Git.Ref.base b , ":" @@ -195,7 +251,7 @@ pushBranch remote branch g = tryIO directpush `after` syncpush mergeAnnex :: CommandStart mergeAnnex = do - void $ Annex.Branch.forceUpdate + void Annex.Branch.forceUpdate stop {- Merges from a branch into the current branch. -} @@ -218,7 +274,7 @@ mergeFrom branch = do mergeDirectCleanup d oldsha newsha _ -> noop return r - runmerge a = ifM (a) + runmerge a = ifM a ( return True , resolveMerge ) @@ -232,72 +288,122 @@ mergeFrom branch = do - - This uses the Keys pointed to by the files to construct new - filenames. So when both sides modified file foo, - - it will be deleted, and replaced with files foo.KEYA and foo.KEYB. + - it will be deleted, and replaced with files foo.variant-A and + - foo.variant-B. - - On the other hand, when one side deleted foo, and the other modified it, - it will be deleted, and the modified version stored as file - - foo.KEYA (or KEYB). + - foo.variant-A (or B). + - + - It's also possible that one side has foo as an annexed file, and + - the other as a directory or non-annexed file. The annexed file + - is renamed to resolve the merge, and the other object is preserved as-is. -} resolveMerge :: Annex Bool resolveMerge = do top <- fromRepo Git.repoPath (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) - merged <- all id <$> mapM resolveMerge' fs + mergedfs <- catMaybes <$> mapM resolveMerge' fs + let merged = not (null mergedfs) void $ liftIO cleanup (deleted, cleanup2) <- inRepo (LsFiles.deleted [top]) unless (null deleted) $ Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted void $ liftIO cleanup2 - + when merged $ do + unlessM isDirect $ + cleanConflictCruft mergedfs top Annex.Queue.flush void $ inRepo $ Git.Command.runBool [ Param "commit" , Param "-m" , Param "git-annex automatic merge conflict fix" ] + showLongNote "Merge conflict was automatically resolved; you may want to examine the result." return merged -resolveMerge' :: LsFiles.Unmerged -> Annex Bool +resolveMerge' :: LsFiles.Unmerged -> Annex (Maybe FilePath) resolveMerge' u - | issymlink LsFiles.valUs && issymlink LsFiles.valThem = - withKey LsFiles.valUs $ \keyUs -> - withKey LsFiles.valThem $ \keyThem -> do + | issymlink LsFiles.valUs && issymlink LsFiles.valThem = do + kus <- getKey LsFiles.valUs + kthem <- getKey LsFiles.valThem + case (kus, kthem) of + -- Both sides of conflict are annexed files + (Just keyUs, Just keyThem) -> do + removeoldfile keyUs + if keyUs == keyThem + then makelink keyUs + else do + makelink keyUs + makelink keyThem + return $ Just file + -- Our side is annexed, other side is not. + (Just keyUs, Nothing) -> do ifM isDirect - ( maybe noop (\k -> removeDirect k file) keyUs - , liftIO $ nukeFile file + -- Move newly added non-annexed object + -- out of direct mode merge directory. + ( do + removeoldfile keyUs + makelink keyUs + d <- fromRepo gitAnnexMergeDir + liftIO $ rename (d </> file) file + -- cleaup tree after git merge + , do + unstageoldfile + makelink keyUs ) - Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] - go keyUs keyThem - | otherwise = return False + return $ Just file + -- Our side is not annexed, other side is. + (Nothing, Just keyThem) -> do + makelink keyThem + unstageoldfile + return $ Just file + -- Neither side is annexed; cannot resolve. + (Nothing, Nothing) -> return Nothing + | otherwise = return Nothing where - go keyUs keyThem - | keyUs == keyThem = do - makelink keyUs - return True - | otherwise = do - makelink keyUs - makelink keyThem - return True file = LsFiles.unmergedFile u - issymlink select = any (select (LsFiles.unmergedBlobType u) ==) - [Just SymlinkBlob, Nothing] - makelink (Just key) = do + issymlink select = select (LsFiles.unmergedBlobType u) `elem` [Just SymlinkBlob, Nothing] + makelink key = do let dest = mergeFile file key l <- inRepo $ gitAnnexLink dest key replaceFile dest $ makeAnnexLink l stageSymlink dest =<< hashSymlink l - whenM (isDirect) $ + whenM isDirect $ toDirect key dest - makelink _ = noop - withKey select a = do - let msha = select $ LsFiles.unmergedSha u - case msha of - Nothing -> a Nothing - Just sha -> do - key <- catKey sha - maybe (return False) (a . Just) key + removeoldfile keyUs = do + ifM isDirect + ( removeDirect keyUs file + , liftIO $ nukeFile file + ) + Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] + unstageoldfile = Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file] + getKey select = case select (LsFiles.unmergedSha u) of + Nothing -> return Nothing + Just sha -> catKey sha symLinkMode + +{- git-merge moves conflicting files away to files + - named something like f~HEAD or f~branch, but the + - exact name chosen can vary. Once the conflict is resolved, + - this cruft can be deleted. To avoid deleting legitimate + - files that look like this, only delete files that are + - A) not staged in git and B) look like git-annex symlinks. + -} +cleanConflictCruft :: [FilePath] -> FilePath -> Annex () +cleanConflictCruft resolvedfs top = do + (fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top] + mapM_ clean fs + void $ liftIO cleanup + where + clean f + | matchesresolved f = whenM (isJust <$> isAnnexLink f) $ + liftIO $ nukeFile f + | otherwise = noop + s = S.fromList resolvedfs + matchesresolved f = S.member (base f) s + base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f {- The filename to use when resolving a conflicted merge of a file, - that points to a key. diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 4bebdebcd..93f6c7077 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -36,7 +36,7 @@ seek = [withWords start] -} start :: [String] -> CommandStart start (k:[]) = do - case (file2key k) of + case file2key k of Nothing -> error "bad key" (Just key) -> whenM (inAnnex key) $ do file <- Fields.getField Fields.associatedFile diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 849cbc12b..3270ad8f7 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -15,23 +15,23 @@ import Logs.Location import Logs.Transfer import qualified Remote import Types.Remote -import qualified Command.Move +import GitAnnex.Options import qualified Option def :: [Command] -def = [withOptions options $ +def = [withOptions transferKeyOptions $ noCommit $ command "transferkey" paramKey seek SectionPlumbing "transfers a key from or to a remote"] -options :: [Option] -options = [fileOption, Command.Move.fromOption, Command.Move.toOption] +transferKeyOptions :: [Option] +transferKeyOptions = fileOption : fromToOptions fileOption :: Option fileOption = Option.field [] "file" paramFile "the associated file" seek :: [CommandSeek] -seek = [withField Command.Move.toOption Remote.byNameWithUUID $ \to -> - withField Command.Move.fromOption Remote.byNameWithUUID $ \from -> +seek = [withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> withField fileOption return $ \file -> withKeys $ start to from file] diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 8da29e211..5ac9454aa 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -41,7 +41,7 @@ seek = [withField readFdOption convertFd $ \readh -> convertFd :: Maybe String -> Annex (Maybe Handle) convertFd Nothing = return Nothing -convertFd (Just s) = liftIO $ do +convertFd (Just s) = liftIO $ case readish s of Nothing -> error "bad fd" Just fd -> Just <$> fdToHandle fd diff --git a/Command/Unannex.hs b/Command/Unannex.hs index fbeaffa52..5e3c4279a 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -13,11 +13,11 @@ import Common.Annex import Command import Config import qualified Annex -import Logs.Location import Annex.Content import Annex.Content.Direct import qualified Git.Command import qualified Git.LsFiles as LsFiles +import Utility.CopyFile def :: [Command] def = [command "unannex" paramPaths seek SectionUtility @@ -46,7 +46,7 @@ performIndirect file key = do -- git as a normal non-annexed file, to thinking that the -- file has been unlocked and needs to be re-annexed. (s, reap) <- inRepo $ LsFiles.staged [file] - when (not $ null s) $ + unless (null s) $ inRepo $ Git.Command.run [ Param "commit" , Param "-q" @@ -60,28 +60,24 @@ performIndirect file key = do cleanupIndirect :: FilePath -> Key -> CommandCleanup cleanupIndirect file key = do + src <- calcRepo $ gitAnnexLocation key ifM (Annex.getState Annex.fast) - ( goFast - , go + ( hardlinkfrom src + , copyfrom src ) - return True where -#ifdef mingw32_HOST_OS - goFast = go -#else - goFast = do - -- fast mode: hard link to content in annex - src <- calcRepo $ gitAnnexLocation key - -- creating a hard link could fall; fall back to non fast mode + copyfrom src = + thawContent file `after` liftIO (copyFileExternal src file) + hardlinkfrom src = +#ifndef mingw32_HOST_OS + -- creating a hard link could fall; fall back to copying ifM (liftIO $ catchBoolIO $ createLink src file >> return True) - ( thawContent file - , go + ( return True + , copyfrom src ) +#else + copyfrom src #endif - go = do - fromAnnex key file - logStatus key InfoMissing - performDirect :: FilePath -> Key -> CommandPerform performDirect file key = do diff --git a/Command/Uninit.hs b/Command/Uninit.hs index a40e28399..3fbe6758a 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -11,7 +11,6 @@ import Common.Annex import Command import qualified Git import qualified Git.Command -import qualified Annex import qualified Command.Unannex import Init import qualified Annex.Branch @@ -38,7 +37,7 @@ check = do seek :: [CommandSeek] seek = [ withFilesNotInGit $ whenAnnexed startCheckIncomplete - , withFilesInGit $ whenAnnexed startUnannex + , withFilesInGit $ whenAnnexed Command.Unannex.start , withNothing start ] @@ -51,14 +50,6 @@ startCheckIncomplete file _ = error $ unlines , "Not continuing with uninit; either delete or git annex add the file and retry." ] -startUnannex :: FilePath -> (Key, Backend) -> CommandStart -startUnannex file info = do - -- Force fast mode before running unannex. This way, if multiple - -- files link to a key, it will be left in the annex and hardlinked - -- to by each. - Annex.changeState $ \s -> s { Annex.fast = True } - Command.Unannex.start file info - start :: CommandStart start = next $ next $ do annexdir <- fromRepo gitAnnexDir diff --git a/Command/Unused.hs b/Command/Unused.hs index 0a060aae6..844cdb19b 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -21,21 +21,22 @@ import Common.Annex import Command import Logs.Unused import Annex.Content -import Utility.FileMode import Logs.Location import Logs.Transfer import qualified Annex import qualified Git import qualified Git.Command import qualified Git.Ref +import qualified Git.Branch import qualified Git.LsFiles as LsFiles -import qualified Git.LsTree as LsTree +import qualified Git.DiffTree as DiffTree import qualified Backend import qualified Remote import qualified Annex.Branch import qualified Option import Annex.CatFile import Types.Key +import Git.FilePath def :: [Command] def = [withOptions [fromOption] $ command "unused" paramNothing seek @@ -241,7 +242,7 @@ withKeysReferenced' mdir initial a = do ( return ([], return True) , do top <- fromRepo Git.repoPath - inRepo $ LsFiles.inRepo [top] + inRepo $ LsFiles.allFiles [top] ) Just dir -> inRepo $ LsFiles.inRepo [dir] go v [] = return v @@ -255,35 +256,47 @@ withKeysReferenced' mdir initial a = do withKeysReferencedInGit :: (Key -> Annex ()) -> Annex () withKeysReferencedInGit a = do - rs <- relevantrefs <$> showref - forM_ rs (withKeysReferencedInGitRef a) + current <- inRepo Git.Branch.currentUnsafe + shaHead <- maybe (return Nothing) (inRepo . Git.Ref.sha) current + showref >>= mapM_ (withKeysReferencedInGitRef a) . + relevantrefs (shaHead, current) where showref = inRepo $ Git.Command.pipeReadStrict [Param "show-ref"] - relevantrefs = map (Git.Ref . snd) . - nubBy uniqref . + relevantrefs headRef = addHead headRef . filter ourbranches . - map (separate (== ' ')) . lines - uniqref (x, _) (y, _) = x == y + map (separate (== ' ')) . + lines + nubRefs = map (Git.Ref . snd) . nubBy (\(x, _) (y, _) -> x == y) ourbranchend = '/' : show Annex.Branch.name ourbranches (_, b) = not (ourbranchend `isSuffixOf` b) && not ("refs/synced/" `isPrefixOf` b) - + addHead headRef refs = case headRef of + -- if HEAD diverges from all branches (except the branch it + -- points to), run the actions on staged keys (and keys + -- that are only present in the work tree if the repo is + -- non bare) + (Just (Git.Ref x), Just (Git.Ref b)) + | all (\(x',b') -> x /= x' || b == b') refs -> + Git.Ref.headRef + : nubRefs (filter ((/= x) . fst) refs) + _ -> nubRefs refs + +{- Runs an action on keys referenced in the given Git reference which + - differ from those referenced in the index. -} withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedInGitRef a ref = do showAction $ "checking " ++ Git.Ref.describe ref - go <=< inRepo $ LsTree.lsTree ref + bare <- isBareRepo + (ts,clean) <- inRepo $ if bare + then DiffTree.diffIndex ref + else DiffTree.diffWorkTree ref + let lookAtWorkingTree = not bare && ref == Git.Ref.headRef + forM_ ts $ tKey lookAtWorkingTree >=> maybe noop a + liftIO $ void clean where - go [] = noop - go (l:ls) - | isSymLink (LsTree.mode l) = do - content <- encodeW8 . L.unpack - <$> catFile ref (LsTree.file l) - case fileKey (takeFileName content) of - Nothing -> go ls - Just k -> do - a k - go ls - | otherwise = go ls + tKey True = fmap fst <$$> Backend.lookupFile . getTopFilePath . DiffTree.file + tKey False = fileKey . takeFileName . encodeW8 . L.unpack <$$> + catFile ref . getTopFilePath . DiffTree.file {- Looks in the specified directory for bad/tmp keys, and returns a list - of those that might still have value, or might be stale and removable. @@ -292,7 +305,7 @@ withKeysReferencedInGitRef a ref = do -} staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key] staleKeysPrune dirspec nottransferred = do - contents <- staleKeys dirspec + contents <- dirKeys dirspec dups <- filterM inAnnex contents let stale = contents `exclude` dups @@ -307,18 +320,6 @@ staleKeysPrune dirspec nottransferred = do return $ filter (`S.notMember` inprogress) stale else return stale -staleKeys :: (Git.Repo -> FilePath) -> Annex [Key] -staleKeys dirspec = do - dir <- fromRepo dirspec - ifM (liftIO $ doesDirectoryExist dir) - ( do - contents <- liftIO $ getDirectoryContents dir - files <- liftIO $ filterM doesFileExist $ - map (dir </>) contents - return $ mapMaybe (fileKey . takeFileName) files - , return [] - ) - data UnusedMaps = UnusedMaps { unusedMap :: UnusedMap , unusedBadMap :: UnusedMap diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index 88ca8622d..66ea0e0eb 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -11,6 +11,7 @@ import Common.Annex import Command import Upgrade import Annex.Version +import Config def :: [Command] def = [dontCheck repoExists $ -- because an old version may not seem to exist @@ -23,6 +24,9 @@ seek = [withNothing start] start :: CommandStart start = do showStart "upgrade" "." - r <- upgrade - setVersion defaultVersion + r <- upgrade False + ifM isDirect + ( setVersion directModeVersion + , setVersion defaultVersion + ) next $ next $ return r diff --git a/Command/Version.hs b/Command/Version.hs index c8507cd5a..b330d1ff1 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -12,6 +12,10 @@ import Command import qualified Build.SysConfig as SysConfig import Annex.Version import BuildFlags +import qualified Types.Backend as B +import qualified Types.Remote as R +import qualified Remote +import qualified Backend def :: [Command] def = [noCommit $ noRepo showPackageVersion $ dontCheck repoExists $ @@ -25,13 +29,20 @@ start = do v <- getVersion liftIO $ do showPackageVersion - putStrLn $ "local repository version: " ++ fromMaybe "unknown" v - putStrLn $ "default repository version: " ++ defaultVersion - putStrLn $ "supported repository versions: " ++ unwords supportedVersions - putStrLn $ "upgrade supported from repository versions: " ++ unwords upgradableVersions + info "local repository version" $ fromMaybe "unknown" v + info "default repository version" defaultVersion + info "supported repository versions" $ + unwords supportedVersions + info "upgrade supported from repository versions" $ + unwords upgradableVersions stop showPackageVersion :: IO () showPackageVersion = do - putStrLn $ "git-annex version: " ++ SysConfig.packageversion - putStrLn $ "build flags: " ++ unwords buildFlags + info "git-annex version" SysConfig.packageversion + info "build flags" $ unwords buildFlags + info "key/value backends" $ unwords $ map B.name Backend.list + info "remote types" $ unwords $ map R.typename Remote.remoteTypes + +info :: String -> String -> IO () +info k v = putStrLn $ k ++ ": " ++ v diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 1aa8722c5..22c641408 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -21,7 +21,9 @@ import Types.Group import Logs.Trust import Logs.Group import Logs.PreferredContent +import Logs.Schedule import Types.StandardGroups +import Types.ScheduledActivity import Remote def :: [Command] @@ -59,6 +61,7 @@ data Cfg = Cfg { cfgTrustMap :: TrustMap , cfgGroupMap :: M.Map UUID (S.Set Group) , cfgPreferredContentMap :: M.Map UUID String + , cfgScheduleMap :: M.Map UUID [ScheduledActivity] } getCfg :: Annex Cfg @@ -66,22 +69,25 @@ getCfg = Cfg <$> trustMapRaw -- without local trust overrides <*> (groupsByUUID <$> groupMap) <*> preferredContentMapRaw + <*> scheduleMap setCfg :: Cfg -> Cfg -> Annex () setCfg curcfg newcfg = do - let (trustchanges, groupchanges, preferredcontentchanges) = diffCfg curcfg newcfg + let (trustchanges, groupchanges, preferredcontentchanges, schedulechanges) = diffCfg curcfg newcfg mapM_ (uncurry trustSet) $ M.toList trustchanges mapM_ (uncurry groupSet) $ M.toList groupchanges mapM_ (uncurry preferredContentSet) $ M.toList preferredcontentchanges + mapM_ (uncurry scheduleSet) $ M.toList schedulechanges -diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String) -diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap) +diffCfg :: Cfg -> Cfg -> (TrustMap, M.Map UUID (S.Set Group), M.Map UUID String, M.Map UUID [ScheduledActivity]) +diffCfg curcfg newcfg = (diff cfgTrustMap, diff cfgGroupMap, diff cfgPreferredContentMap, diff cfgScheduleMap) where diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) (f newcfg) (f curcfg) genCfg :: Cfg -> M.Map UUID String -> String -genCfg cfg descs = unlines $ concat [intro, trust, groups, preferredcontent] +genCfg cfg descs = unlines $ concat + [intro, trust, groups, preferredcontent, schedule] where intro = [ com "git-annex configuration" @@ -120,17 +126,25 @@ genCfg cfg descs = unlines $ concat [intro, trust, groups, preferredcontent] (\(s, u) -> line "content" u s) (\u -> line "content" u "") + schedule = settings cfgScheduleMap + [ "" + , com "Scheduled activities" + , com "(Separate multiple activities with \"; \")" + ] + (\(l, u) -> line "schedule" u $ fromScheduledActivities l) + (\u -> line "schedule" u "") + settings field desc showvals showdefaults = concat [ desc , concatMap showvals $ sort $ map swap $ M.toList $ field cfg - , concatMap (\u -> lcom $ showdefaults u) $ missing field + , concatMap (lcom . showdefaults) $ missing field ] line setting u value = - [ com $ "(for " ++ (fromMaybe "" $ M.lookup u descs) ++ ")" + [ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")" , unwords [setting, fromUUID u, "=", value] ] - lcom = map (\l -> if "#" `isPrefixOf` l then l else "#" ++ l) + lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l) missing field = S.toList $ M.keysSet descs `S.difference` M.keysSet (field cfg) {- If there's a parse error, returns a new version of the file, @@ -139,7 +153,7 @@ parseCfg :: Cfg -> String -> Either String Cfg parseCfg curcfg = go [] curcfg . lines where go c cfg [] - | null (catMaybes $ map fst c) = Right cfg + | null (mapMaybe fst c) = Right cfg | otherwise = Left $ unlines $ badheader ++ concatMap showerr (reverse c) go c cfg (l:ls) = case parse (dropWhile isSpace l) cfg of @@ -173,6 +187,11 @@ parseCfg curcfg = go [] curcfg . lines Nothing -> let m = M.insert u value (cfgPreferredContentMap cfg) in Right $ cfg { cfgPreferredContentMap = m } + | setting == "schedule" = case parseScheduledActivities value of + Left e -> Left e + Right l -> + let m = M.insert u l (cfgScheduleMap cfg) + in Right $ cfg { cfgScheduleMap = m } | otherwise = badval "setting" setting showerr (Just msg, l) = [parseerr ++ msg, l] diff --git a/Command/Content.hs b/Command/Wanted.hs index d10bdde3c..a7b4a3d9e 100644 --- a/Command/Content.hs +++ b/Command/Wanted.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Command.Content where +module Command.Wanted where import Common.Annex import Command @@ -15,7 +15,7 @@ import Logs.PreferredContent import qualified Data.Map as M def :: [Command] -def = [command "content" (paramPair paramRemote (paramOptional paramExpression)) seek +def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek SectionSetup "get or set preferred content expression"] seek :: [CommandSeek] @@ -26,7 +26,7 @@ start = parse where parse (name:[]) = go name performGet parse (name:expr:[]) = go name $ \uuid -> do - showStart "content" name + showStart "wanted" name performSet expr uuid parse _ = error "Specify a repository." diff --git a/Command/Watch.hs b/Command/Watch.hs index c5fd1a8cd..0b34b0f84 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -11,6 +11,7 @@ import Common.Annex import Assistant import Command import Option +import Utility.HumanTime def :: [Command] def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ @@ -19,7 +20,7 @@ def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ seek :: [CommandSeek] seek = [withFlag stopOption $ \stopdaemon -> withFlag foregroundOption $ \foreground -> - withNothing $ start False foreground stopdaemon] + withNothing $ start False foreground stopdaemon Nothing] foregroundOption :: Option foregroundOption = Option.flag [] "foreground" "do not daemonize" @@ -27,9 +28,9 @@ foregroundOption = Option.flag [] "foreground" "do not daemonize" stopOption :: Option stopOption = Option.flag [] "stop" "stop daemon" -start :: Bool -> Bool -> Bool -> CommandStart -start assistant foreground stopdaemon = do +start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart +start assistant foreground stopdaemon startdelay = do if stopdaemon then stopDaemon - else startDaemon assistant foreground Nothing Nothing -- does not return + else startDaemon assistant foreground startdelay Nothing Nothing -- does not return stop diff --git a/Command/WebApp.hs b/Command/WebApp.hs index eeb23a164..88c1537d0 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -55,7 +55,7 @@ start = start' True start' :: Bool -> Maybe HostName -> CommandStart start' allowauto listenhost = do - liftIO $ ensureInstalled + liftIO ensureInstalled ifM isInitialized ( go , auto ) stop where @@ -69,7 +69,7 @@ start' allowauto listenhost = do url <- liftIO . readFile =<< fromRepo gitAnnexUrlFile liftIO $ openBrowser browser f url Nothing Nothing - , startDaemon True True listenhost $ Just $ + , startDaemon True True Nothing listenhost $ Just $ \origout origerr url htmlshim -> if isJust listenhost then maybe noop (`hPutStrLn` url) origout @@ -155,7 +155,7 @@ firstRun listenhost = do _wait <- takeMVar v state <- Annex.new =<< Git.CurrentRepo.get Annex.eval state $ - startDaemon True True listenhost $ Just $ + startDaemon True True Nothing listenhost $ Just $ sendurlback v sendurlback v _origout _origerr url _htmlshim = do recordUrl url @@ -209,7 +209,7 @@ openBrowser mcmd htmlshim realurl outh errh = do , std_err = maybe Inherit UseHandle errh } exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ do + unless (exitcode == ExitSuccess) $ hPutStrLn (fromMaybe stderr errh) "failed to start web browser" {- web.browser is a generic git config setting for a web browser program -} |