diff options
Diffstat (limited to 'Command')
69 files changed, 7001 insertions, 0 deletions
diff --git a/Command/Add.hs b/Command/Add.hs new file mode 100644 index 000000000..9f1beb28a --- /dev/null +++ b/Command/Add.hs @@ -0,0 +1,261 @@ +{- git-annex command + - + - Copyright 2010, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.Add where + +import System.PosixCompat.Files + +import Common.Annex +import Annex.Exception +import Command +import Types.KeySource +import Backend +import Logs.Location +import Annex.Content +import Annex.Content.Direct +import Annex.Perms +import Annex.Link +import qualified Annex +import qualified Annex.Queue +#ifdef WITH_CLIBS +#ifndef __ANDROID__ +import Utility.Touch +#endif +#endif +import Config +import Utility.InodeCache +import Annex.FileMatcher +import Annex.ReplaceFile +import Utility.Tmp + +def :: [Command] +def = [notBareRepo $ command "add" paramPaths seek SectionCommon + "add files to annex"] + +{- Add acts on both files not checked into git yet, and unlocked files. + - + - In direct mode, it acts on any files that have changed. -} +seek :: [CommandSeek] +seek = + [ go withFilesNotInGit + , whenNotDirect $ go withFilesUnlocked + , whenDirect $ go withFilesMaybeModified + ] + where + go a = withValue largeFilesMatcher $ \matcher -> + a $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) + ( start file + , stop + ) + +{- The add subcommand annexes a file, generating a key for it using a + - backend, and then moving it into the annex directory and setting up + - the symlink pointing to its content. -} +start :: FilePath -> CommandStart +start file = ifAnnexed file addpresent add + where + add = do + ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file + case ms of + Nothing -> stop + Just s + | isSymbolicLink s || not (isRegularFile s) -> stop + | otherwise -> do + showStart "add" file + next $ perform file + addpresent (key, _) = ifM isDirect + ( ifM (goodContent key file) ( stop , add ) + , fixup key + ) + fixup key = do + -- fixup from an interrupted add; the symlink + -- is present but not yet added to git + showStart "add" file + liftIO $ removeFile file + 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 + - perfect at best (and pretty weak at worst). For example, it does not + - guard against files that are already opened for write by another process. + - 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. + - + - 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. + - + - Lockdown can fail if a file gets deleted, and Nothing will be returned. + -} +lockDown :: FilePath -> Annex (Maybe KeySource) +lockDown file = ifM crippledFileSystem + ( liftIO $ catchMaybeIO nohardlink + , do + tmp <- fromRepo gitAnnexTmpDir + createAnnexDirectory tmp + 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 + nohardlink = do + cache <- genInodeCache file + return KeySource + { keyFilename = file + , contentLocation = file + , inodeCache = cache + } + withhardlink tmpfile = do + createLink file tmpfile + cache <- genInodeCache tmpfile + return KeySource + { keyFilename = file + , contentLocation = tmpfile + , inodeCache = cache + } + +{- Ingests a locked down file into the annex. + - + - In direct mode, leaves the file alone, and just updates bookkeeping + - information. + -} +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 + cache <- liftIO $ genInodeCache $ contentLocation source + case (cache, inodeCache source) of + (_, Nothing) -> go k cache + (Just newc, Just c) | compareStrong c newc -> go k cache + _ -> failure "changed while it was being added" + where + go k cache = ifM isDirect ( godirect k cache , goindirect k cache ) + + goindirect (Just (key, _)) mcache = do + catchAnnex (moveAnnex key $ contentLocation source) + (undo (keyFilename source) key) + liftIO $ nukeFile $ keyFilename source + 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, 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, Nothing) + +finishIngestDirect :: Key -> KeySource -> Annex () +finishIngestDirect key source = do + void $ addAssociatedFile key $ keyFilename source + when (contentLocation source /= keyFilename source) $ + liftIO $ nukeFile $ contentLocation source + + {- Copy to any other locations using the same key. -} + otherfs <- filter (/= keyFilename source) <$> associatedFiles key + forM_ otherfs $ + addContentWhenNotPresent key (keyFilename source) + +perform :: FilePath -> CommandPerform +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. -} +undo :: FilePath -> Key -> IOException -> Annex a +undo file key e = do + whenM (inAnnex key) $ do + liftIO $ nukeFile file + catchAnnex (fromAnnex key file) tryharder + logStatus key InfoMissing + throwAnnex e + where + -- fromAnnex could fail if the file ownership is weird + tryharder :: IOException -> Annex () + tryharder _ = do + src <- calcRepo $ gitAnnexLocation key + liftIO $ moveFile src file + +{- Creates the symlink to the annexed content, returns the link target. -} +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__ + -- 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 + +{- Creates the symlink to the annexed content, and stages it in git. + - + - As long as the filesystem supports symlinks, we use + - git add, rather than directly staging the symlink to git. + - Using git add is best because it allows the queuing to work + - and is faster (staging the symlink runs hash-object commands each time). + - Also, using git add allows it to skip gitignored files, unless forced + - to include them. + -} +addLink :: FilePath -> Key -> Maybe InodeCache -> Annex () +addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) + ( do + _ <- 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 mcache + addAnnexLink l file + ) + +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 mcache + ) + return True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs new file mode 100644 index 000000000..1a178e8d4 --- /dev/null +++ b/Command/AddUnused.hs @@ -0,0 +1,41 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.AddUnused where + +import Common.Annex +import Logs.Location +import Command +import qualified Command.Add +import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) +import Types.Key + +def :: [Command] +def = [notDirect $ command "addunused" (paramRepeating paramNumRange) + seek SectionMaintenance "add back unused files"] + +seek :: [CommandSeek] +seek = [withUnusedMaps start] + +start :: UnusedMaps -> Int -> CommandStart +start = startUnused "addunused" perform + (performOther "bad") + (performOther "tmp") + +perform :: Key -> CommandPerform +perform key = next $ do + logStatus key InfoPresent + Command.Add.addLink file key Nothing + return True + where + file = "unused." ++ key2file key + +{- The content is not in the annex, but in another directory, and + - it seems better to error out, rather than moving bad/tmp content into + - the annex. -} +performOther :: String -> Key -> CommandPerform +performOther other _ = error $ "cannot addunused " ++ other ++ "content" diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs new file mode 100644 index 000000000..27ca72d1a --- /dev/null +++ b/Command/AddUrl.hs @@ -0,0 +1,231 @@ +{- git-annex command + - + - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.AddUrl where + +import Network.URI + +import Common.Annex +import Command +import Backend +import qualified Command.Add +import qualified Annex +import qualified Annex.Queue +import qualified Annex.Url as Url +import qualified Backend.URL +import Annex.Content +import Logs.Web +import qualified Option +import Types.Key +import Types.KeySource +import Config +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] $ + command "addurl" (paramRepeating paramUrl) seek + SectionCommon "add urls to annex"] + +fileOption :: Option +fileOption = Option.field [] "file" paramFile "specify what file the url is added to" + +pathdepthOption :: Option +pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to use in filename" + +relaxedOption :: Option +relaxedOption = Option.flag [] "relaxed" "skip size check" + +seek :: [CommandSeek] +seek = [withField fileOption return $ \f -> + withFlag relaxedOption $ \relaxed -> + withField pathdepthOption (return . maybe Nothing readish) $ \d -> + withStrings $ start relaxed f d] + +start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart +start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s + where + (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 = choosefile $ truncateFilePath pathmax $ sanitizeFilePath $ + Quvi.pageTitle page ++ "." ++ Quvi.linkSuffix link + showStart "addurl" file + next $ performQuvi relaxed s' (Quvi.linkUrl link) file +#else + usequvi = error "not built with quvi support" +#endif + +#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 + addurl (key, _backend) + | relaxed = do + setUrlPresent key url + next $ return True + | otherwise = do + headers <- getHttpHeaders + (exists, samesize) <- Url.withUserAgent $ Url.check url headers $ keySize key + if exists && samesize + then do + setUrlPresent key url + next $ return True + 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 -> URLString -> FilePath -> Annex Bool +addUrlFile relaxed url file = do + liftIO $ createDirectoryIfMissing True (parentDir file) + ifM (Annex.getState Annex.fast <||> pure relaxed) + ( nodownload relaxed url file + , do + showAction $ "downloading " ++ url ++ " " + download url file + ) + +download :: URLString -> FilePath -> Annex Bool +download url file = do + dummykey <- genkey + tmp <- fromRepo $ gitAnnexTmpLocation dummykey + showOutput + ifM (runtransfer dummykey tmp) + ( do + backend <- chooseBackend file + let source = KeySource + { keyFilename = file + , contentLocation = tmp + , inodeCache = Nothing + } + k <- genKey source backend + case k of + Nothing -> return False + Just (key, _) -> cleanup url file key (Just tmp) + , return False + ) + where + {- Generate a dummy key to use for this download, before we can + - examine the file and find its real key. This allows resuming + - downloads, as the dummy key for a given url is stable. + - + - If the assistant is running, actually hits the url here, + - to get the size, so it can display a pretty progress bar. + -} + genkey = do + pidfile <- fromRepo gitAnnexPidFile + size <- ifM (liftIO $ isJust <$> checkDaemon pidfile) + ( do + headers <- getHttpHeaders + snd <$> Url.withUserAgent (Url.exists url headers) + , return Nothing + ) + Backend.URL.fromUrl url size + runtransfer dummykey tmp = + Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do + liftIO $ createDirectoryIfMissing True (parentDir tmp) + downloadUrl [url] tmp + + +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 Nothing + whenM isDirect $ do + void $ addAssociatedFile key file + {- For moveAnnex to work in direct mode, the symlink + - must already exist, so flush the queue. -} + Annex.Queue.flush + maybe noop (moveAnnex key) mtmp + return True + +nodownload :: Bool -> URLString -> FilePath -> Annex Bool +nodownload relaxed url file = do + headers <- getHttpHeaders + (exists, size) <- if relaxed + then pure (True, Nothing) + else Url.withUserAgent $ Url.exists url headers + if exists + then do + key <- Backend.URL.fromUrl url size + cleanup url file key Nothing + else do + warning $ "unable to access url: " ++ url + return False + +url2file :: URI -> Maybe Int -> Int -> FilePath +url2file url pathdepth pathmax = case pathdepth of + Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl + Just depth + | depth >= length urlbits -> frombits id + | depth > 0 -> frombits $ drop depth + | depth < 0 -> frombits $ reverse . take (negate depth) . reverse + | otherwise -> error "bad --pathdepth" + where + fullurl = uriRegName auth ++ uriPath url ++ uriQuery url + frombits a = intercalate "/" $ a urlbits + urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $ + filter (not . null) $ split "/" fullurl + auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url diff --git a/Command/Assistant.hs b/Command/Assistant.hs new file mode 100644 index 000000000..521a88571 --- /dev/null +++ b/Command/Assistant.hs @@ -0,0 +1,88 @@ +{- git-annex assistant + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Assistant where + +import Common.Annex +import Command +import qualified Option +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 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 -> + withField startDelayOption (pure . maybe Nothing parseDuration) $ \startdelay -> + withNothing $ start foreground stopdaemon autostart startdelay] + +start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart +start foreground stopdaemon autostart startdelay + | autostart = do + liftIO $ autoStart startdelay + stop + | otherwise = do + ensureInitialized + 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 Nothing + , error "Not in a git repository." + ) + +autoStart :: Maybe Duration -> IO () +autoStart startdelay = do + dirs <- liftIO readAutoStartFile + when (null dirs) $ do + f <- autoStartFile + error $ "Nothing listed in " ++ f + program <- readProgramFile + haveionice <- pure Build.SysConfig.ionice <&&> inPath "ionice" + forM_ dirs $ \d -> do + putStrLn $ "git-annex autostart in " ++ d + ifM (catchBoolIO $ go haveionice program d) + ( putStrLn "ok" + , putStrLn "failed" + ) + where + go haveionice program dir = do + setCurrentDirectory dir + if haveionice + 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/Commit.hs b/Command/Commit.hs new file mode 100644 index 000000000..6f3f9df28 --- /dev/null +++ b/Command/Commit.hs @@ -0,0 +1,29 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Commit where + +import Common.Annex +import Command +import qualified Annex.Branch +import qualified Git + +def :: [Command] +def = [command "commit" paramNothing seek + SectionPlumbing "commits any staged changes to the git-annex branch"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = next $ next $ do + Annex.Branch.commit "update" + _ <- runhook <=< inRepo $ Git.hookPath "annex-content" + return True + where + runhook (Just hook) = liftIO $ boolSystem hook [] + runhook Nothing = return True diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs new file mode 100644 index 000000000..c42480200 --- /dev/null +++ b/Command/ConfigList.hs @@ -0,0 +1,30 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +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 + SectionPlumbing "outputs relevant git configuration"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + u <- getUUID + 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 new file mode 100644 index 000000000..9fd97334a --- /dev/null +++ b/Command/Copy.hs @@ -0,0 +1,39 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Copy where + +import Common.Annex +import Command +import GitAnnex.Options +import qualified Command.Move +import qualified Remote +import Annex.Wanted + +def :: [Command] +def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek + SectionCommon "copy content of files to/from another repository"] + +seek :: [CommandSeek] +seek = + [ withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> + withKeyOptions (Command.Move.startKey to from False) $ + withFilesInGit $ whenAnnexed $ start to from + ] + +{- A copy is just a move that does not delete the source file. + - However, --auto mode avoids unnecessary copies, and avoids getting or + - sending non-preferred content. -} +start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start to from file (key, backend) = stopUnless shouldCopy $ + Command.Move.start to from False file (key, backend) + where + shouldCopy = checkAuto (check <||> numCopiesCheck file key (<)) + check = case to of + Nothing -> wantGet False (Just file) + Just r -> wantSend False (Just file) (Remote.uuid r) diff --git a/Command/Dead.hs b/Command/Dead.hs new file mode 100644 index 000000000..180f2fda9 --- /dev/null +++ b/Command/Dead.hs @@ -0,0 +1,40 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Dead where + +import Common.Annex +import Command +import qualified Remote +import Logs.Trust +import Logs.Group + +import qualified Data.Set as S + +def :: [Command] +def = [command "dead" (paramRepeating paramRemote) seek + SectionSetup "hide a lost repository"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ws = do + let name = unwords ws + showStart "dead" name + u <- Remote.nameToUUID name + next $ perform u + +perform :: UUID -> CommandPerform +perform uuid = do + markDead uuid + next $ return True + +markDead :: UUID -> Annex () +markDead uuid = do + trustSet uuid DeadTrusted + groupSet uuid S.empty diff --git a/Command/Describe.hs b/Command/Describe.hs new file mode 100644 index 000000000..18851b172 --- /dev/null +++ b/Command/Describe.hs @@ -0,0 +1,32 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Describe where + +import Common.Annex +import Command +import qualified Remote +import Logs.UUID + +def :: [Command] +def = [command "describe" (paramPair paramRemote paramDesc) seek + SectionSetup "change description of a repository"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start (name:description) = do + showStart "describe" name + u <- Remote.nameToUUID name + next $ perform u $ unwords description +start _ = error "Specify a repository and a description." + +perform :: UUID -> String -> CommandPerform +perform u description = do + describeUUID u description + next $ return True diff --git a/Command/Direct.hs b/Command/Direct.hs new file mode 100644 index 000000000..1f262bd9f --- /dev/null +++ b/Command/Direct.hs @@ -0,0 +1,73 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Direct where + +import Control.Exception.Extensible + +import Common.Annex +import Command +import qualified Git +import qualified Git.Command +import qualified Git.LsFiles +import Config +import Annex.Direct +import Annex.Version +import Annex.Exception + +def :: [Command] +def = [notBareRepo $ noDaemonRunning $ + command "direct" paramNothing seek + SectionSetup "switch repository to direct mode"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = ifM isDirect ( stop , next perform ) + +perform :: CommandPerform +perform = do + showStart "commit" "" + showOutput + _ <- inRepo $ Git.Command.runBool + [ Param "commit" + , Param "-a" + , Param "-m" + , Param "commit before switching to direct mode" + ] + showEndOk + + top <- fromRepo Git.repoPath + (l, clean) <- inRepo $ Git.LsFiles.inRepo [top] + forM_ l go + void $ liftIO clean + next cleanup + where + go = whenAnnexed $ \f (k, _) -> do + r <- toDirectGen k f + case r of + Nothing -> noop + Just a -> do + showStart "direct" f + 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" "" + setDirect True + setVersion directModeVersion + return True diff --git a/Command/Drop.hs b/Command/Drop.hs new file mode 100644 index 000000000..5d642ed3a --- /dev/null +++ b/Command/Drop.hs @@ -0,0 +1,161 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Drop where + +import Common.Annex +import Command +import qualified Remote +import qualified Annex +import Annex.UUID +import Logs.Location +import Logs.Trust +import Annex.Content +import Config +import qualified Option +import Annex.Wanted + +def :: [Command] +def = [withOptions [fromOption] $ command "drop" paramPaths seek + SectionCommon "indicate content of files not currently wanted"] + +fromOption :: Option +fromOption = Option.field ['f'] "from" paramRemote "drop content from a remote" + +seek :: [CommandSeek] +seek = [withField fromOption Remote.byNameWithUUID $ \from -> + withFilesInGit $ whenAnnexed $ start from] + +start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start from file (key, _) = checkDropAuto from file key $ \numcopies -> + stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just file)) $ + case from of + Nothing -> startLocal file numcopies key Nothing + Just remote -> do + u <- getUUID + if Remote.uuid remote == u + then startLocal file numcopies key Nothing + else startRemote file numcopies key remote + +startLocal :: FilePath -> Maybe Int -> Key -> Maybe Remote -> CommandStart +startLocal file numcopies key knownpresentremote = stopUnless (inAnnex key) $ do + showStart "drop" file + next $ performLocal key numcopies knownpresentremote + +startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart +startRemote file numcopies key remote = do + showStart ("drop " ++ Remote.name remote) file + next $ performRemote key numcopies remote + +performLocal :: Key -> Maybe Int -> Maybe Remote -> CommandPerform +performLocal key numcopies knownpresentremote = lockContent key $ do + (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key + let trusteduuids' = case knownpresentremote of + Nothing -> trusteduuids + Just r -> nub (Remote.uuid r:trusteduuids) + untrusteduuids <- trustGet UnTrusted + let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids) + stopUnless (canDropKey key numcopies trusteduuids' tocheck []) $ do + removeAnnex key + next $ cleanupLocal key + +performRemote :: Key -> Maybe Int -> Remote -> CommandPerform +performRemote key numcopies remote = lockContent key $ do + -- Filter the remote it's being dropped from out of the lists of + -- places assumed to have the key, and places to check. + -- When the local repo has the key, that's one additional copy. + (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key + present <- inAnnex key + u <- getUUID + let have = filter (/= uuid) $ + if present then u:trusteduuids else trusteduuids + untrusteduuids <- trustGet UnTrusted + let tocheck = filter (/= remote) $ + Remote.remotesWithoutUUID remotes (have++untrusteduuids) + stopUnless (canDropKey key numcopies have tocheck [uuid]) $ do + ok <- Remote.removeKey remote key + next $ cleanupRemote key remote ok + where + uuid = Remote.uuid remote + +cleanupLocal :: Key -> CommandCleanup +cleanupLocal key = do + logStatus key InfoMissing + return True + +cleanupRemote :: Key -> Remote -> Bool -> CommandCleanup +cleanupRemote key remote ok = do + when ok $ + Remote.logStatus remote key InfoMissing + return ok + +{- Checks specified remotes to verify that enough copies of a key exist to + - allow it to be safely removed (with no data loss). Can be provided with + - some locations where the key is known/assumed to be present. -} +canDropKey :: Key -> Maybe Int -> [UUID] -> [Remote] -> [UUID] -> Annex Bool +canDropKey key numcopiesM have check skip = do + force <- Annex.getState Annex.force + if force || numcopiesM == Just 0 + then return True + else do + need <- getNumCopies numcopiesM + findCopies key need skip have check + +findCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool +findCopies key need skip = helper [] [] + where + helper bad missing have [] + | length have >= need = return True + | otherwise = notEnoughCopies key need have (skip++missing) bad + helper bad missing have (r:rs) + | length have >= need = return True + | otherwise = do + let u = Remote.uuid r + let duplicate = u `elem` have + haskey <- Remote.hasKey r key + case (duplicate, haskey) of + (False, Right True) -> helper bad missing (u:have) rs + (False, Left _) -> helper (r:bad) missing have rs + (False, Right False) -> helper bad (u:missing) have rs + _ -> helper bad missing have rs + +notEnoughCopies :: Key -> Int -> [UUID] -> [UUID] -> [Remote] -> Annex Bool +notEnoughCopies key need have skip bad = do + unsafe + showLongNote $ + "Could only verify the existence of " ++ + show (length have) ++ " out of " ++ show need ++ + " necessary copies" + Remote.showTriedRemotes bad + Remote.showLocations key (have++skip) + "Rather than dropping this file, try using: git annex move" + hint + return False + where + 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 on other semitrusted repositories. + - + - Passes any numcopies attribute of the file on to the action as an + - optimisation. -} +checkDropAuto :: Maybe Remote -> FilePath -> Key -> (Maybe Int -> CommandStart) -> CommandStart +checkDropAuto mremote file key a = do + numcopiesattr <- numCopies file + Annex.getState Annex.auto >>= auto numcopiesattr + where + auto numcopiesattr False = a numcopiesattr + auto numcopiesattr True = do + needed <- getNumCopies numcopiesattr + locs <- Remote.keyLocations key + uuid <- getUUID + let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote + locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs + if length locs' >= needed + then a numcopiesattr + else stop diff --git a/Command/DropKey.hs b/Command/DropKey.hs new file mode 100644 index 000000000..624919584 --- /dev/null +++ b/Command/DropKey.hs @@ -0,0 +1,39 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.DropKey where + +import Common.Annex +import Command +import qualified Annex +import Logs.Location +import Annex.Content +import Types.Key + +def :: [Command] +def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek + SectionPlumbing "drops annexed content for specified keys"] + +seek :: [CommandSeek] +seek = [withKeys start] + +start :: Key -> CommandStart +start key = stopUnless (inAnnex key) $ do + unlessM (Annex.getState Annex.force) $ + error "dropkey can cause data loss; use --force if you're sure you want to do this" + showStart "dropkey" (key2file key) + next $ perform key + +perform :: Key -> CommandPerform +perform key = lockContent key $ do + removeAnnex key + next $ cleanup key + +cleanup :: Key -> CommandCleanup +cleanup key = do + logStatus key InfoMissing + return True diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs new file mode 100644 index 000000000..bf2635e00 --- /dev/null +++ b/Command/DropUnused.hs @@ -0,0 +1,43 @@ +{- git-annex command + - + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.DropUnused where + +import Common.Annex +import Command +import qualified Annex +import qualified Command.Drop +import qualified Remote +import qualified Git +import qualified Option +import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) + +def :: [Command] +def = [withOptions [Command.Drop.fromOption] $ + command "dropunused" (paramRepeating paramNumRange) + seek SectionMaintenance "drop unused file content"] + +seek :: [CommandSeek] +seek = [withUnusedMaps start] + +start :: UnusedMaps -> Int -> CommandStart +start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation) + +perform :: Key -> CommandPerform +perform key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from + where + dropremote r = do + showAction $ "from " ++ Remote.name r + Command.Drop.performRemote key Nothing r + droplocal = Command.Drop.performLocal key Nothing Nothing + from = Annex.getField $ Option.name Command.Drop.fromOption + +performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform +performOther filespec key = do + f <- fromRepo $ filespec key + liftIO $ nukeFile f + next $ return True diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs new file mode 100644 index 000000000..f6a1b819c --- /dev/null +++ b/Command/EnableRemote.hs @@ -0,0 +1,56 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.EnableRemote where + +import Common.Annex +import Command +import qualified Logs.Remote +import qualified Types.Remote as R +import qualified Command.InitRemote as InitRemote + +import qualified Data.Map as M + +def :: [Command] +def = [command "enableremote" + (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) + seek SectionSetup "enables use of an existing special remote"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start [] = unknownNameError "Specify the name of the special remote to enable." +start (name:ws) = go =<< InitRemote.findExisting name + where + config = Logs.Remote.keyValToConfig ws + + go Nothing = unknownNameError "Unknown special remote name." + go (Just (u, c)) = do + let fullconfig = config `M.union` c + t <- InitRemote.findType fullconfig + + showStart "enableremote" name + next $ perform t u fullconfig + +unknownNameError :: String -> Annex a +unknownNameError prefix = do + names <- InitRemote.remoteNames + error $ prefix ++ + if null names + then "" + else " Known special remotes: " ++ unwords names + +perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform +perform t u c = do + (c', u') <- R.setup t (Just u) c + next $ cleanup u' c' + +cleanup :: UUID -> R.RemoteConfig -> CommandCleanup +cleanup u c = do + Logs.Remote.configSet u c + return True diff --git a/Command/Find.hs b/Command/Find.hs new file mode 100644 index 000000000..4b8c7ce0e --- /dev/null +++ b/Command/Find.hs @@ -0,0 +1,61 @@ +{- git-annex command + - + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Find where + +import qualified Data.Map as M + +import Common.Annex +import Command +import Annex.Content +import Limit +import qualified Annex +import qualified Utility.Format +import Utility.DataUnits +import Types.Key +import qualified Option + +def :: [Command] +def = [noCommit $ noMessages $ withOptions [formatOption, print0Option] $ + command "find" paramPaths seek SectionQuery "lists available files"] + +formatOption :: Option +formatOption = Option.field [] "format" paramFormat "control format of output" + +print0Option :: Option +print0Option = Option.Option [] ["print0"] (Option.NoArg set) + "terminate output with null" + where + set = Annex.setField (Option.name formatOption) "${file}\0" + +seek :: [CommandSeek] +seek = [withField formatOption formatconverter $ \f -> + withFilesInGit $ whenAnnexed $ start f] + where + formatconverter = return . fmap Utility.Format.gen + +start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart +start format file (key, _) = do + -- only files inAnnex are shown, unless the user has requested + -- others via a limit + whenM (limited <||> inAnnex key) $ + unlessM (showFullJSON vars) $ + case format of + Nothing -> liftIO $ putStrLn file + Just formatter -> liftIO $ putStr $ + Utility.Format.format formatter $ + M.fromList vars + stop + where + vars = + [ ("file", file) + , ("key", key2file key) + , ("backend", keyBackendName key) + , ("bytesize", size show) + , ("humansize", size $ roughSize storageUnits True) + ] + size c = maybe "unknown" c $ keySize key diff --git a/Command/Fix.hs b/Command/Fix.hs new file mode 100644 index 000000000..a63a10f8f --- /dev/null +++ b/Command/Fix.hs @@ -0,0 +1,61 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.Fix where + +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 + SectionMaintenance "fix up symlinks to point to annexed content"] + +seek :: [CommandSeek] +seek = [withFilesInGit $ whenAnnexed start] + +{- Fixes the symlink to an annexed file. -} +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, _) = do + link <- inRepo $ gitAnnexLink file key + stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do + showStart "fix" file + next $ perform file link + +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 +cleanup file = do + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] + return True 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/FromKey.hs b/Command/FromKey.hs new file mode 100644 index 000000000..c3d2daafe --- /dev/null +++ b/Command/FromKey.hs @@ -0,0 +1,46 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.FromKey where + +import System.PosixCompat.Files + +import Common.Annex +import Command +import qualified Annex.Queue +import Annex.Content +import Types.Key + +def :: [Command] +def = [notDirect $ notBareRepo $ + command "fromkey" (paramPair paramKey paramPath) seek + SectionPlumbing "adds a file using a specific key"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start (keyname:file:[]) = do + let key = fromMaybe (error "bad key") $ file2key keyname + inbackend <- inAnnex key + unless inbackend $ error $ + "key ("++ keyname ++") is not present in backend" + showStart "fromkey" file + next $ perform key file +start _ = error "specify a key and a dest file" + +perform :: Key -> FilePath -> CommandPerform +perform key file = do + link <- inRepo $ gitAnnexLink file key + liftIO $ createDirectoryIfMissing True (parentDir file) + liftIO $ createSymbolicLink link file + next $ cleanup file + +cleanup :: FilePath -> CommandCleanup +cleanup file = do + Annex.Queue.addCommand "add" [Param "--"] [file] + return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs new file mode 100644 index 000000000..a8e52af98 --- /dev/null +++ b/Command/Fsck.hs @@ -0,0 +1,508 @@ +{- git-annex command + - + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.Fsck where + +import System.PosixCompat.Files + +import Common.Annex +import Command +import qualified Annex +import qualified Remote +import qualified Types.Backend +import qualified Types.Key +import qualified Backend +import Annex.Content +import Annex.Content.Direct +import Annex.Direct +import Annex.Perms +import Annex.Link +import Logs.Location +import Logs.Trust +import Annex.UUID +import Utility.DataUnits +import Utility.FileMode +import Config +import qualified Option +import Types.Key +import Utility.HumanTime +import Git.FilePath +import GitAnnex.Options hiding (fromOption) + +#ifndef mingw32_HOST_OS +import System.Posix.Process (getProcessID) +#else +import System.Random (getStdRandom, random) +#endif +import Data.Time.Clock.POSIX +import Data.Time +import System.Posix.Types (EpochTime) +import System.Locale + +def :: [Command] +def = [withOptions fsckOptions $ command "fsck" paramPaths seek + SectionMaintenance "check for problems"] + +fromOption :: Option +fromOption = Option.field ['f'] "from" paramRemote "check remote" + +startIncrementalOption :: Option +startIncrementalOption = Option.flag ['S'] "incremental" "start an incremental fsck" + +moreIncrementalOption :: Option +moreIncrementalOption = Option.flag ['m'] "more" "continue an incremental fsck" + +incrementalScheduleOption :: Option +incrementalScheduleOption = Option.field [] "incremental-schedule" paramTime + "schedule incremental fscking" + +fsckOptions :: [Option] +fsckOptions = + [ fromOption + , startIncrementalOption + , moreIncrementalOption + , incrementalScheduleOption + ] ++ keyOptions + +seek :: [CommandSeek] +seek = + [ withField fromOption Remote.byNameWithUUID $ \from -> + withIncremental $ \i -> + withKeyOptions (startKey i) $ + withFilesInGit $ whenAnnexed $ start from i + ] + +withIncremental :: (Incremental -> CommandSeek) -> CommandSeek +withIncremental = withValue $ do + i <- maybe (return False) (checkschedule . parseDuration) + =<< Annex.getField (Option.name incrementalScheduleOption) + starti <- Annex.getFlag (Option.name startIncrementalOption) + morei <- Annex.getFlag (Option.name moreIncrementalOption) + case (i, starti, morei) of + (False, False, False) -> return NonIncremental + (False, True, _) -> startIncremental + (False ,False, True) -> ContIncremental <$> getStartTime + (True, _, _) -> + maybe startIncremental (return . ContIncremental . Just) + =<< getStartTime + where + startIncremental = do + recordStartTime + return StartIncremental + + checkschedule Nothing = error "bad --incremental-schedule value" + checkschedule (Just delta) = do + Annex.addCleanup "" $ do + v <- getStartTime + case v of + Nothing -> noop + Just started -> do + now <- liftIO getPOSIXTime + when (now - realToFrac started >= durationToPOSIXTime delta) + resetStartTime + return True + +start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart +start from inc file (key, backend) = do + numcopies <- numCopies file + case from of + Nothing -> go $ perform key file backend numcopies + Just r -> go $ performRemote key file backend numcopies r + where + go = runFsck inc file key + +perform :: Key -> FilePath -> Backend -> Maybe Int -> Annex Bool +perform key file backend numcopies = check + -- order matters + [ fixLink key file + , verifyLocationLog key file + , verifyDirectMapping key file + , verifyDirectMode key file + , checkKeySize key + , checkBackend backend key (Just file) + , checkKeyNumCopies key file numcopies + ] + +{- To fsck a remote, the content is retrieved to a tmp file, + - and checked locally. -} +performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> Annex Bool +performRemote key file backend numcopies remote = + dispatch =<< Remote.hasKey remote key + where + dispatch (Left err) = do + showNote err + return False + dispatch (Right True) = withtmp $ \tmpfile -> + ifM (getfile tmpfile) + ( go True (Just tmpfile) + , go True Nothing + ) + dispatch (Right False) = go False Nothing + go present localcopy = check + [ verifyLocationLogRemote key file remote present + , checkKeySizeRemote key remote localcopy + , checkBackendRemote backend key remote localcopy + , checkKeyNumCopies key file numcopies + ] + withtmp a = do +#ifndef mingw32_HOST_OS + v <- liftIO getProcessID +#else + v <- liftIO (getStdRandom random :: IO Int) +#endif + t <- fromRepo gitAnnexTmpDir + createAnnexDirectory t + let tmp = t </> "fsck" ++ show v ++ "." ++ keyFile key + let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) + cleanup + cleanup `after` a tmp + getfile tmp = + ifM (Remote.retrieveKeyFileCheap remote key tmp) + ( return True + , ifM (Annex.getState Annex.fast) + ( return False + , Remote.retrieveKeyFile remote key Nothing tmp dummymeter + ) + ) + dummymeter _ = noop + +startKey :: Incremental -> Key -> CommandStart +startKey inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of + Nothing -> stop + Just backend -> runFsck inc (key2file key) key $ performAll key backend + +{- Note that numcopies cannot be checked in --all mode, since we do not + - have associated filenames to look up in the .gitattributes file. -} +performAll :: Key -> Backend -> Annex Bool +performAll key backend = check + [ verifyLocationLog key (key2file key) + , checkKeySize key + , checkBackend backend key Nothing + ] + +check :: [Annex Bool] -> Annex Bool +check cs = and <$> sequence cs + +{- Checks that the file's link points correctly to the content. + - + - In direct mode, there is only a link when the content is not present. + -} +fixLink :: Key -> FilePath -> Annex Bool +fixLink key file = do + want <- inRepo $ gitAnnexLink file key + have <- getAnnexLinkTarget file + maybe noop (go want) have + return True + where + go want have + | want /= fromInternalGitPath have = do + showNote "fixing link" + liftIO $ createDirectoryIfMissing True (parentDir file) + liftIO $ removeFile file + addAnnexLink want file + | otherwise = noop + +{- Checks that the location log reflects the current status of the key, + - in this repository only. -} +verifyLocationLog :: Key -> String -> Annex Bool +verifyLocationLog key desc = do + present <- inAnnex key + direct <- isDirect + u <- getUUID + + {- Since we're checking that a key's file is present, throw + - in a permission fixup here too. -} + file <- calcRepo $ gitAnnexLocation key + when (present && not direct) $ + freezeContent file + whenM (liftIO $ doesDirectoryExist $ parentDir file) $ + freezeContentDir file + + {- 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 + then return True + else verifyLocationLog' key desc present u (logChange key u) + +verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool +verifyLocationLogRemote key desc remote present = + verifyLocationLog' key desc present (Remote.uuid remote) + (Remote.logStatus remote key) + +verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool +verifyLocationLog' key desc present u bad = do + uuids <- Remote.keyLocations key + case (present, u `elem` uuids) of + (True, False) -> do + fix InfoPresent + -- There is no data loss, so do not fail. + return True + (False, True) -> do + fix InfoMissing + warning $ + "** Based on the location log, " ++ desc + ++ "\n** was expected to be present, " ++ + "but its content is missing." + return False + _ -> return True + where + fix s = do + showNote "fixing location log" + bad s + +{- Ensures the direct mode mapping file is consistent. Each file + - it lists for the key should exist, and the specified file should be + - included in it. + -} +verifyDirectMapping :: Key -> FilePath -> Annex Bool +verifyDirectMapping key file = do + whenM isDirect $ do + fs <- addAssociatedFile key file + forM_ fs $ \f -> + unlessM (liftIO $ doesFileExist f) $ + void $ removeAssociatedFile key f + return True + +{- Ensures that files whose content is available are in direct mode. -} +verifyDirectMode :: Key -> FilePath -> Annex Bool +verifyDirectMode key file = do + whenM (isDirect <&&> isJust <$> isAnnexLink file) $ do + v <- toDirectGen key file + case v of + Nothing -> noop + Just a -> do + showNote "fixing direct mode" + a + return True + +{- The size of the data for a key is checked against the size encoded in + - the key's metadata, if available. + - + - Not checked in direct mode, because files can be changed directly. + -} +checkKeySize :: Key -> Annex Bool +checkKeySize key = ifM isDirect + ( return True + , do + file <- calcRepo $ gitAnnexLocation key + ifM (liftIO $ doesFileExist file) + ( checkKeySizeOr badContent key file + , return True + ) + ) + +checkKeySizeRemote :: Key -> Remote -> Maybe FilePath -> Annex Bool +checkKeySizeRemote _ _ Nothing = return True +checkKeySizeRemote key remote (Just file) = + checkKeySizeOr (badContentRemote remote) key file + +checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> Annex Bool +checkKeySizeOr bad key file = case Types.Key.keySize key of + Nothing -> return True + Just size -> do + size' <- fromIntegral . fileSize + <$> liftIO (getFileStatus file) + comparesizes size size' + where + comparesizes a b = do + let same = a == b + unless same $ badsize a b + return same + badsize a b = do + msg <- bad key + warning $ concat + [ "Bad file size (" + , compareSizes storageUnits True a b + , "); " + , msg + ] + +{- Runs the backend specific check on a key's content. + - + - In direct mode this is not done if the file has clearly been modified, + - because modification of direct mode files is allowed. It's still done + - if the file does not appear modified, to catch disk corruption, etc. + -} +checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool +checkBackend backend key mfile = go =<< isDirect + where + go False = do + content <- calcRepo $ gitAnnexLocation key + checkBackendOr badContent backend key content + go True = maybe nocheck checkdirect mfile + checkdirect file = ifM (goodContent key file) + ( checkBackendOr' (badContentDirect file) backend key file + (goodContent key file) + , nocheck + ) + nocheck = return True + +checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool +checkBackendRemote backend key remote = maybe (return True) go + where + go = checkBackendOr (badContentRemote remote) backend key + +checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool +checkBackendOr bad backend key file = + checkBackendOr' bad backend key file (return True) + +checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> Annex Bool -> Annex Bool +checkBackendOr' bad backend key file postcheck = + case Types.Backend.fsckKey backend of + Nothing -> return True + Just a -> do + ok <- a key file + ifM postcheck + ( do + unless ok $ do + msg <- bad key + warning $ "Bad file content; " ++ msg + return ok + , return True + ) + +checkKeyNumCopies :: Key -> FilePath -> Maybe Int -> Annex Bool +checkKeyNumCopies key file numcopies = do + needed <- getNumCopies numcopies + (untrustedlocations, safelocations) <- trustPartition UnTrusted =<< Remote.keyLocations key + let present = length safelocations + if present < needed + then do + ppuuids <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations + warning $ missingNote file present needed ppuuids + return False + else return True + +missingNote :: String -> Int -> Int -> String -> String +missingNote file 0 _ [] = + "** No known copies exist of " ++ file +missingNote file 0 _ untrusted = + "Only these untrusted locations may have copies of " ++ file ++ + "\n" ++ untrusted ++ + "Back it up to trusted locations with git-annex copy." +missingNote file present needed [] = + "Only " ++ show present ++ " of " ++ show needed ++ + " trustworthy copies exist of " ++ file ++ + "\nBack it up with git-annex copy." +missingNote file present needed untrusted = + missingNote file present needed [] ++ + "\nThe following untrusted locations may also have copies: " ++ + "\n" ++ untrusted + +{- Bad content is moved aside. -} +badContent :: Key -> Annex String +badContent key = do + dest <- moveBad key + return $ "moved to " ++ dest + +{- Bad content is left where it is, but we touch the file, so it'll be + - committed to a new key. -} +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" + +badContentRemote :: Remote -> Key -> Annex String +badContentRemote remote key = do + ok <- Remote.removeKey remote key + when ok $ + Remote.logStatus remote key InfoMissing + return $ (if ok then "dropped from " else "failed to drop from ") + ++ Remote.name remote + +data Incremental = StartIncremental | ContIncremental (Maybe EpochTime) | NonIncremental + deriving (Eq) + +runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart +runFsck inc file key a = ifM (needFsck inc key) + ( do + showStart "fsck" file + next $ do + ok <- a + when ok $ + recordFsckTime key + next $ return ok + , stop + ) + +{- Check if a key needs to be fscked, with support for incremental fscks. -} +needFsck :: Incremental -> Key -> Annex Bool +needFsck (ContIncremental Nothing) _ = return True +needFsck (ContIncremental starttime) key = do + fscktime <- getFsckTime key + return $ fscktime < starttime +needFsck _ _ = return True + +{- To record the time that a key was last fscked, without + - modifying its mtime, we set the timestamp of its parent directory. + - Each annexed file is the only thing in its directory, so this is fine. + - + - To record that the file was fscked, the directory's sticky bit is set. + - (None of the normal unix behaviors of the sticky bit should matter, so + - we can reuse this permission bit.) + - + - Note that this relies on the parent directory being deleted when a file + - is dropped. That way, if it's later added back, the fsck record + - won't still be present. + -} +recordFsckTime :: Key -> Annex () +recordFsckTime key = do + parent <- parentDir <$> calcRepo (gitAnnexLocation key) + liftIO $ void $ tryIO $ do + touchFile parent +#ifndef mingw32_HOST_OS + setSticky parent +#endif + +getFsckTime :: Key -> Annex (Maybe EpochTime) +getFsckTime key = do + parent <- parentDir <$> calcRepo (gitAnnexLocation key) + liftIO $ catchDefaultIO Nothing $ do + s <- getFileStatus parent + return $ if isSticky $ fileMode s + then Just $ modificationTime s + else Nothing + +{- Records the start time of an incremental fsck. + - + - To guard against time stamp damange (for example, if an annex directory + - is copied without -a), the fsckstate file contains a time that should + - be identical to its modification time. -} +recordStartTime :: Annex () +recordStartTime = do + f <- fromRepo gitAnnexFsckState + createAnnexDirectory $ parentDir f + liftIO $ do + nukeFile f + h <- openFile f WriteMode + t <- modificationTime <$> getFileStatus f + hPutStr h $ showTime $ realToFrac t + hClose h + where + showTime :: POSIXTime -> String + showTime = show + +resetStartTime :: Annex () +resetStartTime = liftIO . nukeFile =<< fromRepo gitAnnexFsckState + +{- Gets the incremental fsck start time. -} +getStartTime :: Annex (Maybe EpochTime) +getStartTime = do + f <- fromRepo gitAnnexFsckState + liftIO $ catchDefaultIO Nothing $ do + timestamp <- modificationTime <$> getFileStatus f + t <- readishTime <$> readFile f + return $ if Just (realToFrac timestamp) == t + then Just timestamp + else Nothing + where + readishTime :: String -> Maybe POSIXTime + readishTime s = utcTimeToPOSIXSeconds <$> + parseTime defaultTimeLocale "%s%Qs" s diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs new file mode 100644 index 000000000..34e74b433 --- /dev/null +++ b/Command/FuzzTest.hs @@ -0,0 +1,288 @@ +{- git-annex fuzz generator + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.FuzzTest where + +import Common.Annex +import qualified Annex +import Command +import qualified Git.Config +import Config +import Utility.ThreadScheduler +import Annex.Exception +import Utility.DiskFree + +import Data.Time.Clock +import System.Random (getStdRandom, random, randomR) +import Test.QuickCheck +import Control.Concurrent + +def :: [Command] +def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing + "generates fuzz test files"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + guardTest + logf <- fromRepo gitAnnexFuzzTestLogFile + showStart "fuzztest" logf + logh <-liftIO $ openFile logf WriteMode + void $ forever $ fuzz logh + stop + +guardTest :: Annex () +guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $ + error $ unlines + [ "Running fuzz tests *writes* to and *deletes* files in" + , "this repository, and pushes those changes to other" + , "repositories! This is a developer tool, not something" + , "to play with." + , "" + , "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!" + ] + where + key = annexConfig "eat-my-repository" + (ConfigKey keyname) = key + + +fuzz :: Handle -> Annex () +fuzz logh = do + action <- genFuzzAction + record logh $ flip Started action + result <- tryAnnex $ runFuzzAction action + record logh $ flip Finished $ + either (const False) (const True) result + +record :: Handle -> (UTCTime -> TimeStampedFuzzAction) -> Annex () +record h tmpl = liftIO $ do + now <- getCurrentTime + let s = show $ tmpl now + print s + hPrint h s + hFlush h + +{- Delay for either a fraction of a second, or a few seconds, or up + - to 1 minute. + - + - The MinutesDelay is used as an opportunity to do housekeeping tasks. + -} +randomDelay :: Delay -> Annex () +randomDelay TinyDelay = liftIO $ + threadDelay =<< getStdRandom (randomR (10000, 1000000)) +randomDelay SecondsDelay = liftIO $ + threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 10)) +randomDelay MinutesDelay = do + liftIO $ threadDelaySeconds =<< Seconds <$> getStdRandom (randomR (1, 60)) + reserve <- annexDiskReserve <$> Annex.getGitConfig + free <- liftIO $ getDiskFree "." + case free of + Just have | have < reserve -> do + warning "Low disk space; fuzz test paused." + liftIO $ threadDelaySeconds (Seconds 60) + randomDelay MinutesDelay + _ -> noop + +data Delay + = TinyDelay + | SecondsDelay + | MinutesDelay + deriving (Read, Show, Eq) + +instance Arbitrary Delay where + arbitrary = elements [TinyDelay, SecondsDelay, MinutesDelay] + +data FuzzFile = FuzzFile FilePath + deriving (Read, Show, Eq) + +data FuzzDir = FuzzDir FilePath + deriving (Read, Show, Eq) + +instance Arbitrary FuzzFile where + arbitrary = FuzzFile <$> arbitrary + +instance Arbitrary FuzzDir where + arbitrary = FuzzDir <$> arbitrary + +class ToFilePath a where + toFilePath :: a -> FilePath + +instance ToFilePath FuzzFile where + toFilePath (FuzzFile f) = f + +instance ToFilePath FuzzDir where + toFilePath (FuzzDir d) = d + +isFuzzFile :: FilePath -> Bool +isFuzzFile f = "fuzzfile_" `isPrefixOf` takeFileName f + +isFuzzDir :: FilePath -> Bool +isFuzzDir d = "fuzzdir_" `isPrefixOf` d + +mkFuzzFile :: FilePath -> [FuzzDir] -> FuzzFile +mkFuzzFile file dirs = FuzzFile $ joinPath (map toFilePath dirs) </> ("fuzzfile_" ++ file) + +mkFuzzDir :: Int -> FuzzDir +mkFuzzDir n = FuzzDir $ "fuzzdir_" ++ show n + +{- File is placed inside a directory hierarchy up to 4 subdirectories deep. -} +genFuzzFile :: IO FuzzFile +genFuzzFile = do + n <- getStdRandom $ randomR (0, 4) + dirs <- replicateM n genFuzzDir + file <- show <$> (getStdRandom random :: IO Int) + return $ mkFuzzFile file dirs + +{- Only 16 distinct subdirectories are used. When nested 4 deep, this + - yields 69904 total directories max, which is below the default Linux + - inotify limit of 81920. The goal is not to run the assistant out of + - inotify descriptors. -} +genFuzzDir :: IO FuzzDir +genFuzzDir = mkFuzzDir <$> (getStdRandom (randomR (1,16)) :: IO Int) + +localFile :: FilePath -> Bool +localFile f + | isAbsolute f = False + | ".." `isInfixOf` f = False + | ".git" `isPrefixOf` f = False + | otherwise = True + +data TimeStampedFuzzAction + = Started UTCTime FuzzAction + | Finished UTCTime Bool + deriving (Read, Show) + +data FuzzAction + = FuzzAdd FuzzFile + | FuzzDelete FuzzFile + | FuzzMove FuzzFile FuzzFile + | FuzzModify FuzzFile + | FuzzDeleteDir FuzzDir + | FuzzMoveDir FuzzDir FuzzDir + | FuzzPause Delay + deriving (Read, Show, Eq) + +instance Arbitrary FuzzAction where + arbitrary = frequency + [ (50, FuzzAdd <$> arbitrary) + , (50, FuzzDelete <$> arbitrary) + , (10, FuzzMove <$> arbitrary <*> arbitrary) + , (10, FuzzModify <$> arbitrary) + , (10, FuzzDeleteDir <$> arbitrary) + , (10, FuzzMoveDir <$> arbitrary <*> arbitrary) + , (10, FuzzPause <$> arbitrary) + ] + +runFuzzAction :: FuzzAction -> Annex () +runFuzzAction (FuzzAdd (FuzzFile f)) = liftIO $ do + createDirectoryIfMissing True $ parentDir f + n <- getStdRandom random :: IO Int + writeFile f $ show n ++ "\n" +runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ nukeFile f +runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ + rename src dest +runFuzzAction (FuzzModify (FuzzFile f)) = whenM isDirect $ liftIO $ do + n <- getStdRandom random :: IO Int + appendFile f $ show n ++ "\n" +runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ + removeDirectoryRecursive d +runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ + rename src dest +runFuzzAction (FuzzPause d) = randomDelay d + +genFuzzAction :: Annex FuzzAction +genFuzzAction = do + tmpl <- liftIO $ Prelude.head <$> sample' (arbitrary :: Gen FuzzAction) + -- Fix up template action to make sense in the current repo tree. + case tmpl of + FuzzAdd _ -> do + f <- liftIO newFile + maybe genFuzzAction (return . FuzzAdd) f + FuzzDelete _ -> do + f <- liftIO $ existingFile 0 "" + maybe genFuzzAction (return . FuzzDelete) f + FuzzMove _ _ -> do + src <- liftIO $ existingFile 0 "" + dest <- liftIO newFile + case (src, dest) of + (Just s, Just d) -> return $ FuzzMove s d + _ -> genFuzzAction + FuzzMoveDir _ _ -> do + md <- liftIO existingDir + case md of + Nothing -> genFuzzAction + Just d -> do + newd <- liftIO $ newDir (parentDir $ toFilePath d) + maybe genFuzzAction (return . FuzzMoveDir d) newd + FuzzDeleteDir _ -> do + d <- liftIO existingDir + maybe genFuzzAction (return . FuzzDeleteDir) d + FuzzModify _ -> do + f <- liftIO $ existingFile 0 "" + maybe genFuzzAction (return . FuzzModify) f + FuzzPause _ -> return tmpl + +existingFile :: Int -> FilePath -> IO (Maybe FuzzFile) +existingFile 0 _ = return Nothing +existingFile n top = do + dir <- existingDirIncludingTop + contents <- catchDefaultIO [] (getDirectoryContents dir) + let files = filter isFuzzFile contents + if null files + then do + let dirs = filter isFuzzDir contents + if null dirs + then return Nothing + else do + i <- getStdRandom $ randomR (0, length dirs - 1) + existingFile (n - 1) (top </> dirs !! i) + else do + i <- getStdRandom $ randomR (0, length files - 1) + return $ Just $ FuzzFile $ top </> dir </> files !! i + +existingDirIncludingTop :: IO FilePath +existingDirIncludingTop = do + dirs <- filter isFuzzDir <$> getDirectoryContents "." + if null dirs + then return "." + else do + n <- getStdRandom $ randomR (0, length dirs) + return $ ("." : dirs) !! n + +existingDir :: IO (Maybe FuzzDir) +existingDir = do + d <- existingDirIncludingTop + return $ if isFuzzDir d + then Just $ FuzzDir d + else Nothing + +newFile :: IO (Maybe FuzzFile) +newFile = go (100 :: Int) + where + go 0 = return Nothing + go n = do + f <- genFuzzFile + ifM (doesnotexist (toFilePath f)) + ( return $ Just f + , go (n - 1) + ) + +newDir :: FilePath -> IO (Maybe FuzzDir) +newDir parent = go (100 :: Int) + where + go 0 = return Nothing + go n = do + (FuzzDir d) <- genFuzzDir + ifM (doesnotexist (parent </> d)) + ( return $ Just $ FuzzDir d + , go (n - 1) + ) + +doesnotexist :: FilePath -> IO Bool +doesnotexist f = isNothing <$> catchMaybeIO (getSymbolicLinkStatus f) 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 new file mode 100644 index 000000000..9adf79393 --- /dev/null +++ b/Command/Get.hs @@ -0,0 +1,90 @@ +{- git-annex command + - + - Copyright 2010, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Get where + +import Common.Annex +import Command +import qualified Remote +import Annex.Content +import Logs.Transfer +import Annex.Wanted +import GitAnnex.Options +import qualified Command.Move +import Types.Key + +def :: [Command] +def = [withOptions getOptions $ command "get" paramPaths seek + SectionCommon "make content of annexed files available"] + +getOptions :: [Option] +getOptions = fromOption : keyOptions + +seek :: [CommandSeek] +seek = + [ withField fromOption Remote.byNameWithUUID $ \from -> + withKeyOptions (startKeys from) $ + withFilesInGit $ whenAnnexed $ start from + ] + +start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart +start from file (key, _) = start' expensivecheck from key (Just file) + where + expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file)) + +startKeys :: Maybe Remote -> Key -> CommandStart +startKeys from key = start' (return True) from key Nothing + +start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart +start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $ + stopUnless expensivecheck $ + case from of + Nothing -> go $ perform key afile + Just src -> + stopUnless (Command.Move.fromOk src key) $ + go $ Command.Move.fromPerform src False key afile + where + go a = do + showStart "get" (fromMaybe (key2file key) afile) + next a + +perform :: Key -> AssociatedFile -> CommandPerform +perform key afile = stopUnless (getViaTmp key $ getKeyFile key afile) $ + next $ return True -- no cleanup needed + +{- Try to find a copy of the file in one of the remotes, + - and copy it to here. -} +getKeyFile :: Key -> AssociatedFile -> FilePath -> Annex Bool +getKeyFile key afile dest = dispatch =<< Remote.keyPossibilities key + where + dispatch [] = do + showNote "not available" + showlocs + return False + dispatch remotes = trycopy remotes remotes + trycopy full [] = do + Remote.showTriedRemotes full + showlocs + return False + trycopy full (r:rs) = + ifM (probablyPresent r) + ( docopy r (trycopy full rs) + , trycopy full rs + ) + 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. + probablyPresent r + | Remote.hasKeyCheap r = + either (const False) id <$> Remote.hasKey r key + | otherwise = return True + docopy r continue = do + ok <- download (Remote.uuid r) key afile noRetry $ \p -> do + showAction $ "from " ++ Remote.name r + Remote.retrieveKeyFile r key afile dest p + if ok then return ok else continue diff --git a/Command/Group.hs b/Command/Group.hs new file mode 100644 index 000000000..4c0bf4899 --- /dev/null +++ b/Command/Group.hs @@ -0,0 +1,35 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Group where + +import Common.Annex +import Command +import qualified Remote +import Logs.Group +import Types.Group + +import qualified Data.Set as S + +def :: [Command] +def = [command "group" (paramPair paramRemote paramDesc) seek + SectionSetup "add a repository to a group"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start (name:g:[]) = do + showStart "group" name + u <- Remote.nameToUUID name + next $ perform u g +start _ = error "Specify a repository and a group." + +perform :: UUID -> Group -> CommandPerform +perform uuid g = do + groupChange uuid (S.insert g) + next $ return True diff --git a/Command/Help.hs b/Command/Help.hs new file mode 100644 index 000000000..c77f739c1 --- /dev/null +++ b/Command/Help.hs @@ -0,0 +1,62 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Help where + +import Common.Annex +import Command +import qualified Command.Init +import qualified Command.Add +import qualified Command.Drop +import qualified Command.Get +import qualified Command.Move +import qualified Command.Copy +import qualified Command.Sync +import qualified Command.Whereis +import qualified Command.Fsck +import GitAnnex.Options + +import System.Console.GetOpt + +def :: [Command] +def = [noCommit $ noRepo showGeneralHelp $ dontCheck repoExists $ + command "help" paramNothing seek SectionQuery "display help"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ["options"] = do + liftIO showCommonOptions + stop +start _ = do + liftIO showGeneralHelp + stop + +showCommonOptions :: IO () +showCommonOptions = putStrLn $ usageInfo "Common options:" options + +showGeneralHelp :: IO () +showGeneralHelp = putStrLn $ unlines + [ "The most frequently used git-annex commands are:" + , unlines $ map cmdline $ concat + [ Command.Init.def + , Command.Add.def + , Command.Drop.def + , Command.Get.def + , Command.Move.def + , Command.Copy.def + , Command.Sync.def + , Command.Whereis.def + , Command.Fsck.def + ] + , "Run 'git-annex' for a complete command list." + , "Run 'git-annex command --help' for help on a specific command." + , "Run `git annex help options' for a list of common options." + ] + where + cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c diff --git a/Command/Import.hs b/Command/Import.hs new file mode 100644 index 000000000..dcadd96ce --- /dev/null +++ b/Command/Import.hs @@ -0,0 +1,104 @@ +{- git-annex command + - + - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Import where + +import System.PosixCompat.Files + +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 = [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 = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode] + +start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart +start mode (srcfile, destfile) = + ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) + ( do + showStart "import" destfile + next $ perform mode srcfile destfile + , stop + ) + +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 new file mode 100644 index 000000000..45a0d3b7e --- /dev/null +++ b/Command/ImportFeed.hs @@ -0,0 +1,218 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.ImportFeed where + +import Text.Feed.Import +import Text.Feed.Query +import Text.Feed.Types +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Time.Clock + +import Common.Annex +import qualified Annex +import Command +import qualified Annex.Url as Url +import Logs.Web +import qualified Option +import qualified Utility.Format +import Utility.Tmp +import Command.AddUrl (addUrlFile, relaxedOption) +import Annex.Perms +import Backend.URL (fromUrl) + +def :: [Command] +def = [notBareRepo $ withOptions [templateOption, relaxedOption] $ + command "importfeed" (paramRepeating paramUrl) seek + SectionCommon "import files from podcast feeds"] + +templateOption :: Option +templateOption = Option.field [] "template" paramFormat "template for filenames" + +seek :: [CommandSeek] +seek = [withField templateOption return $ \tmpl -> + withFlag relaxedOption $ \relaxed -> + withValue (getCache tmpl) $ \cache -> + withStrings $ start relaxed cache] + +start :: Bool -> Cache -> URLString -> CommandStart +start relaxed cache url = do + showStart "importfeed" url + next $ perform relaxed cache url + +perform :: Bool -> Cache -> URLString -> CommandPerform +perform relaxed cache url = do + v <- findEnclosures url + case v of + Just l | not (null l) -> do + 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 + +cleanup :: URLString -> Bool -> CommandCleanup +cleanup url ok = do + when ok $ + clearFeedProblem url + return ok + +data ToDownload = ToDownload + { feed :: Feed + , feedurl :: URLString + , item :: Item + , location :: URLString + } + +mkToDownload :: Feed -> URLString -> Item -> Maybe ToDownload +mkToDownload f u i = case getItemEnclosure i of + Nothing -> Nothing + Just (enclosureurl, _, _) -> Just $ ToDownload f u i enclosureurl + +data Cache = Cache + { knownurls :: S.Set URLString + , template :: Utility.Format.Format + } + +getCache :: Maybe String -> Annex Cache +getCache opttemplate = ifM (Annex.getState Annex.force) + ( ret S.empty + , do + showSideAction "checking known urls" + ret =<< S.fromList <$> knownUrls + ) + where + tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate + ret s = return $ Cache s tmpl + +findEnclosures :: URLString -> Annex (Maybe [ToDownload]) +findEnclosures url = extract <$> downloadFeed url + where + extract Nothing = Nothing + extract (Just f) = Just $ mapMaybe (mkToDownload f url) (feedItems f) + +{- Feeds change, so a feed download cannot be resumed. -} +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 ua) + ( parseFeedString <$> hGetContentsStrict h + , return Nothing + ) + +{- Avoids downloading any urls that are already known to be associated + - with a file in the annex, unless forced. -} +downloadEnclosure :: Bool -> Cache -> ToDownload -> Annex Bool +downloadEnclosure relaxed cache enclosure + | S.member url (knownurls cache) = ifM forced (go, return True) + | otherwise = go + where + forced = Annex.getState Annex.force + url = location enclosure + go = do + dest <- makeunique (1 :: Integer) $ feedFile (template cache) enclosure + case dest of + Nothing -> return True + Just f -> do + showStart "addurl" f + ok <- addUrlFile relaxed url f + if ok + then do + showEndOk + return True + else do + showEndFail + checkFeedBroken (feedurl enclosure) + {- Find a unique filename to save the url to. + - If the file exists, prefixes it with a number. + - When forced, the file may already exist and have the same + - url, in which case Nothing is returned as it does not need + - to be re-downloaded. -} + makeunique n file = ifM alreadyexists + ( ifM forced + ( ifAnnexed f checksameurl tryanother + , tryanother + ) + , return $ Just f + ) + where + f = if n < 2 + then file + else + let (d, base) = splitFileName file + in d </> show n ++ "_" ++ base + tryanother = makeunique (n + 1) file + alreadyexists = liftIO $ isJust <$> catchMaybeIO (getSymbolicLinkStatus f) + checksameurl (k, _) = ifM (elem url <$> getUrls k) + ( return Nothing + , tryanother + ) + +defaultTemplate :: String +defaultTemplate = "${feedtitle}/${itemtitle}${extension}" + +{- Generates a filename to use for a feed item by filling out the template. + - The filename may not be unique. -} +feedFile :: Utility.Format.Format -> ToDownload -> FilePath +feedFile tmpl i = Utility.Format.format tmpl $ M.fromList + [ field "feedtitle" $ getFeedTitle $ feed i + , fieldMaybe "itemtitle" $ getItemTitle $ item i + , fieldMaybe "feedauthor" $ getFeedAuthor $ feed i + , fieldMaybe "itemauthor" $ getItemAuthor $ item i + , fieldMaybe "itemsummary" $ getItemSummary $ item i + , fieldMaybe "itemdescription" $ getItemDescription $ item i + , fieldMaybe "itemrights" $ getItemRights $ item i + , fieldMaybe "itemid" $ snd <$> getItemId (item i) + , ("extension", sanitizeFilePath $ takeExtension $ location i) + ] + where + field k v = + 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 + +{- 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 () +feedProblem url message = ifM (checkFeedBroken url) + ( error $ message ++ " (having repeated problems with this feed!)" + , warning $ "warning: " ++ message + ) + +{- A feed is only broken if problems have occurred repeatedly, for at + - least 23 hours. -} +checkFeedBroken :: URLString -> Annex Bool +checkFeedBroken url = checkFeedBroken' url =<< feedState url +checkFeedBroken' :: URLString -> FilePath -> Annex Bool +checkFeedBroken' url f = do + prev <- maybe Nothing readish <$> liftIO (catchMaybeIO $ readFile f) + now <- liftIO getCurrentTime + case prev of + Nothing -> do + createAnnexDirectory (parentDir f) + liftIO $ writeFile f $ show now + return False + Just prevtime -> do + let broken = diffUTCTime now prevtime > 60 * 60 * 23 + when broken $ + -- Avoid repeatedly complaining about + -- broken feed. + clearFeedProblem url + return broken + +clearFeedProblem :: URLString -> Annex () +clearFeedProblem url = void $ liftIO . tryIO . removeFile =<< feedState url + +feedState :: URLString -> Annex FilePath +feedState url = fromRepo . gitAnnexFeedState =<< fromUrl url Nothing diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs new file mode 100644 index 000000000..4410d722d --- /dev/null +++ b/Command/InAnnex.hs @@ -0,0 +1,27 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.InAnnex where + +import Common.Annex +import Command +import Annex.Content + +def :: [Command] +def = [noCommit $ command "inannex" (paramRepeating paramKey) seek + SectionPlumbing "checks if keys are present in the annex"] + +seek :: [CommandSeek] +seek = [withKeys start] + +start :: Key -> CommandStart +start key = inAnnexSafe key >>= dispatch + where + dispatch (Just True) = stop + dispatch (Just False) = exit 1 + dispatch Nothing = exit 100 + exit n = liftIO $ exitWith $ ExitFailure n diff --git a/Command/Indirect.hs b/Command/Indirect.hs new file mode 100644 index 000000000..8b857e2f6 --- /dev/null +++ b/Command/Indirect.hs @@ -0,0 +1,113 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +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 +import Annex.Content +import Annex.Content.Direct +import Annex.CatFile +import Annex.Version +import Annex.Exception +import Init +import qualified Command.Add + +def :: [Command] +def = [notBareRepo $ noDaemonRunning $ + command "indirect" paramNothing seek + SectionSetup "switch repository to indirect mode"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = ifM isDirect + ( do + unlessM (coreSymlinks <$> Annex.getGitConfig) $ + error "Git is configured to not use symlinks, so you must use direct mode." + whenM probeCrippledFileSystem $ + error "This repository seems to be on a crippled filesystem, you must use direct mode." + next perform + , stop + ) + +perform :: CommandPerform +perform = do + showStart "commit" "" + whenM stageDirect $ do + showOutput + void $ inRepo $ Git.Command.runBool + [ Param "commit" + , Param "-m" + , Param "commit before switching to indirect mode" + ] + showEndOk + + -- Note that we set indirect mode early, so that we can use + -- moveAnnex in indirect mode. + setDirect False + + top <- fromRepo Git.repoPath + (l, clean) <- inRepo $ Git.LsFiles.stagedOthersDetails [top] + forM_ l go + void $ liftIO clean + next cleanup + where + {- 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 (f, Just sha, Just mode) | isSymLink mode = do + r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f + case r of + Just s + | isSymbolicLink s -> void $ flip whenAnnexed f $ + \_ (k, _) -> do + removeInodeCache k + removeAssociatedFiles k + return Nothing + | otherwise -> + maybe noop (fromdirect f) + =<< catKey sha mode + _ -> noop + go _ = noop + + fromdirect f k = do + showStart "indirect" f + removeInodeCache k + removeAssociatedFiles k + whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do + 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" + +cleanup :: CommandCleanup +cleanup = do + setVersion defaultVersion + showStart "indirect" "" + showEndOk + return True 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/Init.hs b/Command/Init.hs new file mode 100644 index 000000000..3db9a6be3 --- /dev/null +++ b/Command/Init.hs @@ -0,0 +1,31 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Init where + +import Common.Annex +import Command +import Init + +def :: [Command] +def = [dontCheck repoExists $ + command "init" paramDesc seek SectionSetup "initialize git-annex"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ws = do + showStart "init" description + next $ perform description + where + description = unwords ws + +perform :: String -> CommandPerform +perform description = do + initialize $ if null description then Nothing else Just description + next $ return True diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs new file mode 100644 index 000000000..5a240f800 --- /dev/null +++ b/Command/InitRemote.hs @@ -0,0 +1,98 @@ +{- git-annex command + - + - Copyright 2011,2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.InitRemote where + +import qualified Data.Map as M + +import Common.Annex +import Command +import qualified Remote +import qualified Logs.Remote +import qualified Types.Remote as R +import Logs.UUID +import Logs.Trust + +import Data.Ord + +def :: [Command] +def = [command "initremote" + (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) + seek SectionSetup "creates a special (non-git) remote"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start [] = error "Specify a name for the remote." +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 + let c = newConfig name + t <- findType config + + showStart "initremote" name + next $ perform t name $ M.union config c + ) + where + config = Logs.Remote.keyValToConfig ws + +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 +cleanup u name c = do + describeUUID u name + Logs.Remote.configSet u c + return True + +{- See if there's an existing special remote with this name. -} +findExisting :: String -> Annex (Maybe (UUID, R.RemoteConfig)) +findExisting name = do + t <- trustMap + matches <- sortBy (comparing $ \(u, _c) -> M.lookup u t ) + . findByName name + <$> Logs.Remote.readRemoteLog + return $ headMaybe matches + +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 + where + matching c = case M.lookup nameKey c of + Nothing -> False + Just n' + | n' == n -> True + | otherwise -> False + +remoteNames :: Annex [String] +remoteNames = do + m <- Logs.Remote.readRemoteLog + return $ mapMaybe (M.lookup nameKey . snd) $ M.toList m + +{- find the specified remote type -} +findType :: R.RemoteConfig -> Annex RemoteType +findType config = maybe unspecified specified $ M.lookup typeKey config + where + unspecified = error "Specify the type of remote with type=" + specified s = case filter (findtype s) Remote.remoteTypes of + [] -> error $ "Unknown remote type " ++ s + (t:_) -> return t + findtype s i = R.typename i == s + +{- The name of a configured remote is stored in its config using this key. -} +nameKey :: String +nameKey = "name" + +{- The type of a remote is stored in its config using this key. -} +typeKey :: String +typeKey = "type" 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/Lock.hs b/Command/Lock.hs new file mode 100644 index 000000000..6dc58df74 --- /dev/null +++ b/Command/Lock.hs @@ -0,0 +1,29 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Lock where + +import Common.Annex +import Command +import qualified Annex.Queue + +def :: [Command] +def = [notDirect $ command "lock" paramPaths seek SectionCommon + "undo unlock command"] + +seek :: [CommandSeek] +seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start] + +start :: FilePath -> CommandStart +start file = do + showStart "lock" file + next $ perform file + +perform :: FilePath -> CommandPerform +perform file = do + Annex.Queue.addCommand "checkout" [Param "--"] [file] + next $ return True -- no cleanup needed diff --git a/Command/Log.hs b/Command/Log.hs new file mode 100644 index 000000000..f3a5becb8 --- /dev/null +++ b/Command/Log.hs @@ -0,0 +1,171 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Log where + +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Time.Clock.POSIX +import Data.Time +import System.Locale +import Data.Char + +import Common.Annex +import Command +import Logs +import qualified Logs.Presence +import Annex.CatFile +import qualified Annex.Branch +import qualified Git +import Git.Command +import qualified Remote +import qualified Option +import qualified Annex + +data RefChange = RefChange + { changetime :: POSIXTime + , oldref :: Git.Ref + , newref :: Git.Ref + } + +type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () + +def :: [Command] +def = [withOptions options $ + command "log" paramPaths seek SectionQuery "shows location log"] + +options :: [Option] +options = passthruOptions ++ [gourceOption] + +passthruOptions :: [Option] +passthruOptions = map odate ["since", "after", "until", "before"] ++ + [ Option.field ['n'] "max-count" paramNumber + "limit number of logs displayed" + ] + where + odate n = Option.field [] n paramDate $ "show log " ++ n ++ " date" + +gourceOption :: Option +gourceOption = Option.flag [] "gource" "format output for gource" + +seek :: [CommandSeek] +seek = [withValue Remote.uuidDescriptions $ \m -> + withValue (liftIO getCurrentTimeZone) $ \zone -> + withValue (concat <$> mapM getoption passthruOptions) $ \os -> + withFlag gourceOption $ \gource -> + withFilesInGit $ whenAnnexed $ start m zone os gource] + where + getoption o = maybe [] (use o) <$> + Annex.getField (Option.name o) + use o v = [Param ("--" ++ Option.name o), Param v] + +start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool -> + FilePath -> (Key, Backend) -> CommandStart +start m zone os gource file (key, _) = do + showLog output =<< readLog <$> getLog key os + -- getLog produces a zombie; reap it + liftIO reapZombies + stop + where + output + | gource = gourceOutput lookupdescription file + | otherwise = normalOutput lookupdescription file zone + lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m + +showLog :: Outputter -> [RefChange] -> Annex () +showLog outputter ps = do + sets <- mapM (getset newref) ps + previous <- maybe (return genesis) (getset oldref) (lastMaybe ps) + sequence_ $ compareChanges outputter $ sets ++ [previous] + where + genesis = (0, S.empty) + getset select change = do + s <- S.fromList <$> get (select change) + return (changetime change, s) + get ref = map toUUID . Logs.Presence.getLog . L.unpack <$> + catObject ref + +normalOutput :: (UUID -> String) -> FilePath -> TimeZone -> Outputter +normalOutput lookupdescription file zone present ts us = + liftIO $ mapM_ (putStrLn . format) us + where + time = showTimeStamp zone ts + addel = if present then "+" else "-" + format u = unwords [ addel, time, file, "|", + fromUUID u ++ " -- " ++ lookupdescription u ] + +gourceOutput :: (UUID -> String) -> FilePath -> Outputter +gourceOutput lookupdescription file present ts us = + liftIO $ mapM_ (putStrLn . intercalate "|" . format) us + where + time = takeWhile isDigit $ show ts + addel = if present then "A" else "M" + format u = [ time, lookupdescription u, addel, file ] + +{- Generates a display of the changes (which are ordered with newest first), + - by comparing each change with the previous change. + - Uses a formatter to generate a display of items that are added and + - removed. -} +compareChanges :: Ord a => (Bool -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a)] -> [b] +compareChanges format changes = concatMap diff $ zip changes (drop 1 changes) + where + diff ((ts, new), (_, old)) = + [format True ts added, format False ts removed] + where + added = S.toList $ S.difference new old + removed = S.toList $ S.difference old new + +{- Gets the git log for a given location log file. + - + - This is complicated by git log using paths relative to the current + - directory, even when looking at files in a different branch. A wacky + - relative path to the log file has to be used. + - + - The --remove-empty is a significant optimisation. It relies on location + - log files never being deleted in normal operation. Letting git stop + - once the location log file is gone avoids it checking all the way back + - to commit 0 to see if it used to exist, so generally speeds things up a + - *lot* for newish files. -} +getLog :: Key -> [CommandParam] -> Annex [String] +getLog key os = do + top <- fromRepo Git.repoPath + p <- liftIO $ relPathCwdToFile top + let logfile = p </> locationLogFile key + inRepo $ pipeNullSplitZombie $ + [ Params "log -z --pretty=format:%ct --raw --abbrev=40" + , Param "--remove-empty" + ] ++ os ++ + [ Param $ show Annex.Branch.fullname + , Param "--" + , Param logfile + ] + +readLog :: [String] -> [RefChange] +readLog = mapMaybe (parse . lines) + where + parse (ts:raw:[]) = let (old, new) = parseRaw raw in + Just RefChange + { changetime = parseTimeStamp ts + , oldref = old + , newref = new + } + parse _ = Nothing + +-- Parses something like ":100644 100644 oldsha newsha M" +parseRaw :: String -> (Git.Ref, Git.Ref) +parseRaw l = go $ words l + where + go (_:_:oldsha:newsha:_) = (Git.Ref oldsha, Git.Ref newsha) + go _ = error $ "unable to parse git log output: " ++ l + +parseTimeStamp :: String -> POSIXTime +parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") . + parseTime defaultTimeLocale "%s" + +showTimeStamp :: TimeZone -> POSIXTime -> String +showTimeStamp zone = show . utcToLocalTime zone . posixSecondsToUTCTime diff --git a/Command/Map.hs b/Command/Map.hs new file mode 100644 index 000000000..91f4a0251 --- /dev/null +++ b/Command/Map.hs @@ -0,0 +1,247 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Map where + +import Control.Exception.Extensible +import qualified Data.Map as M + +import Common.Annex +import Command +import qualified Git +import qualified Git.Url +import qualified Git.Config +import qualified Git.Construct +import qualified Annex +import Annex.UUID +import Logs.UUID +import Logs.Trust +import qualified Remote.Helper.Ssh as Ssh +import qualified Utility.Dot as Dot + +-- a link from the first repository to the second (its remote) +data Link = Link Git.Repo Git.Repo + +def :: [Command] +def = [dontCheck repoExists $ + command "map" paramNothing seek SectionQuery + "generate map of repositories"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + rs <- combineSame <$> (spider =<< gitRepo) + + umap <- uuidMap + trusted <- trustGet Trusted + + file <- (</>) <$> fromRepo gitAnnexDir <*> pure "map.dot" + + liftIO $ writeFile file (drawMap rs umap trusted) + next $ next $ + ifM (Annex.getState Annex.fast) + ( return True + , do + showLongNote $ "running: dot -Tx11 " ++ file + showOutput + liftIO $ boolSystem "dot" [Param "-Tx11", File file] + ) + +{- Generates a graph for dot(1). Each repository, and any other uuids, are + - displayed as a node, and each of its remotes is represented as an edge + - pointing at the node for the remote. + - + - The order nodes are added to the graph matters, since dot will draw + - the first ones near to the top and left. So it looks better to put + - the repositories first, followed by uuids that were not matched + - to a repository. + -} +drawMap :: [Git.Repo] -> M.Map UUID String -> [UUID] -> String +drawMap rs umap ts = Dot.graph $ repos ++ trusted ++ others + where + repos = map (node umap rs) rs + ruuids = ts ++ map getUncachedUUID rs + others = map (unreachable . uuidnode) $ + filter (`notElem` ruuids) (M.keys umap) + trusted = map (trustworthy . uuidnode) ts + uuidnode u = Dot.graphNode (fromUUID u) $ M.findWithDefault "" u umap + +hostname :: Git.Repo -> String +hostname r + | Git.repoIsUrl r = fromMaybe (Git.repoLocation r) (Git.Url.host r) + | otherwise = "localhost" + +basehostname :: Git.Repo -> String +basehostname r = fromMaybe "" $ headMaybe $ split "." $ hostname r + +{- A name to display for a repo. Uses the name from uuid.log if available, + - or the remote name if not. -} +repoName :: M.Map UUID String -> Git.Repo -> String +repoName umap r + | repouuid == NoUUID = fallback + | otherwise = M.findWithDefault fallback repouuid umap + where + repouuid = getUncachedUUID r + fallback = fromMaybe "unknown" $ Git.remoteName r + +{- A unique id for the node for a repo. Uses the annex.uuid if available. -} +nodeId :: Git.Repo -> String +nodeId r = + case getUncachedUUID r of + NoUUID -> Git.repoLocation r + UUID u -> u + +{- A node representing a repo. -} +node :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> String +node umap fullinfo r = unlines $ n:edges + where + n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ + decorate $ Dot.graphNode (nodeId r) (repoName umap r) + edges = map (edge umap fullinfo r) (Git.remotes r) + decorate + | Git.config r == M.empty = unreachable + | otherwise = reachable + +{- An edge between two repos. The second repo is a remote of the first. -} +edge :: M.Map UUID String -> [Git.Repo] -> Git.Repo -> Git.Repo -> String +edge umap fullinfo from to = + Dot.graphEdge (nodeId from) (nodeId fullto) edgename + where + -- get the full info for the remote, to get its UUID + fullto = findfullinfo to + findfullinfo n = + case filter (same n) fullinfo of + [] -> n + (n':_) -> n' + {- Only name an edge if the name is different than the name + - that will be used for the destination node, and is + - different from its hostname. (This reduces visual clutter.) -} + edgename = maybe Nothing calcname $ Git.remoteName to + calcname n + | n `elem` [repoName umap fullto, hostname fullto] = Nothing + | otherwise = Just n + +unreachable :: String -> String +unreachable = Dot.fillColor "red" +reachable :: String -> String +reachable = Dot.fillColor "white" +trustworthy :: String -> String +trustworthy = Dot.fillColor "green" + +{- Recursively searches out remotes starting with the specified repo. -} +spider :: Git.Repo -> Annex [Git.Repo] +spider r = spider' [r] [] +spider' :: [Git.Repo] -> [Git.Repo] -> Annex [Git.Repo] +spider' [] known = return known +spider' (r:rs) known + | any (same r) known = spider' rs known + | otherwise = do + r' <- scan r + + -- The remotes will be relative to r', and need to be + -- made absolute for later use. + remotes <- mapM (absRepo r') (Git.remotes r') + let r'' = r' { Git.remotes = remotes } + + spider' (rs ++ remotes) (r'':known) + +{- Converts repos to a common absolute form. -} +absRepo :: Git.Repo -> Git.Repo -> Annex Git.Repo +absRepo reference r + | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r + | Git.repoIsUrl r = return r + | otherwise = liftIO $ Git.Construct.fromAbsPath =<< absPath (Git.repoPath r) + +{- Checks if two repos are the same. -} +same :: Git.Repo -> Git.Repo -> Bool +same a b + | both Git.repoIsSsh = matching Git.Url.authority && matching Git.repoPath + | both Git.repoIsUrl && neither Git.repoIsSsh = matching show + | neither Git.repoIsSsh = matching Git.repoPath + | otherwise = False + where + matching t = t a == t b + both t = t a && t b + neither t = not (t a) && not (t b) + +{- reads the config of a remote, with progress display -} +scan :: Git.Repo -> Annex Git.Repo +scan r = do + showStart "map" $ Git.repoDescribe r + v <- tryScan r + case v of + Just r' -> do + showEndOk + return r' + Nothing -> do + showOutput + showEndFail + return r + +{- tries to read the config of a remote, returning it only if it can + - be accessed -} +tryScan :: Git.Repo -> Annex (Maybe Git.Repo) +tryScan r + | Git.repoIsSsh r = sshscan + | Git.repoIsUrl r = return Nothing + | otherwise = safely $ Git.Config.read r + where + safely a = do + result <- liftIO (try a :: IO (Either SomeException Git.Repo)) + case result of + Left _ -> return Nothing + Right r' -> return $ Just r' + pipedconfig cmd params = safely $ + withHandle StdoutHandle createProcessSuccess p $ + Git.Config.hRead r + where + p = proc cmd $ toCommand params + + configlist = Ssh.onRemote r (pipedconfig, Nothing) "configlist" [] [] + manualconfiglist = do + sshparams <- Ssh.toRepo r [Param sshcmd] + liftIO $ pipedconfig "ssh" sshparams + where + sshcmd = cddir ++ " && " ++ + "git config --null --list" + dir = Git.repoPath r + cddir + | "/~" `isPrefixOf` dir = + let (userhome, reldir) = span (/= '/') (drop 1 dir) + in "cd " ++ userhome ++ " && cd " ++ shellEscape (drop 1 reldir) + | otherwise = "cd " ++ shellEscape dir + + -- First, try sshing and running git config manually, + -- only fall back to git-annex-shell configlist if that + -- fails. + -- + -- This is done for two reasons, first I'd like this + -- subcommand to be usable on non-git-annex repos. + -- Secondly, configlist doesn't include information about + -- the remote's remotes. + sshscan = do + sshnote + v <- manualconfiglist + case v of + Nothing -> do + sshnote + configlist + ok -> return ok + + sshnote = do + showAction "sshing" + showOutput + +{- Spidering can find multiple paths to the same repo, so this is used + - to combine (really remove) duplicate repos with the same UUID. -} +combineSame :: [Git.Repo] -> [Git.Repo] +combineSame = map snd . nubBy sameuuid . map pair + where + sameuuid (u1, _) (u2, _) = u1 == u2 && u1 /= NoUUID + pair r = (getUncachedUUID r, r) diff --git a/Command/Merge.hs b/Command/Merge.hs new file mode 100644 index 000000000..31db7a99f --- /dev/null +++ b/Command/Merge.hs @@ -0,0 +1,38 @@ +{- git-annex command + - + - Copyright 2011, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Merge where + +import Common.Annex +import Command +import qualified Annex.Branch +import qualified Git.Branch +import Command.Sync (prepMerge, mergeLocal) + +def :: [Command] +def = [command "merge" paramNothing seek SectionMaintenance + "automatically merge changes from remotes"] + +seek :: [CommandSeek] +seek = + [ withNothing mergeBranch + , withNothing mergeSynced + ] + +mergeBranch :: CommandStart +mergeBranch = do + showStart "merge" "git-annex" + next $ do + Annex.Branch.update + -- commit explicitly, in case no remote branches were merged + Annex.Branch.commit "update" + next $ return True + +mergeSynced :: CommandStart +mergeSynced = do + prepMerge + mergeLocal =<< inRepo Git.Branch.current diff --git a/Command/Migrate.hs b/Command/Migrate.hs new file mode 100644 index 000000000..0fdf0e817 --- /dev/null +++ b/Command/Migrate.hs @@ -0,0 +1,77 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Migrate where + +import Common.Annex +import Command +import Backend +import qualified Types.Key +import qualified Types.Backend +import Types.KeySource +import Annex.Content +import qualified Command.ReKey +import qualified Command.Fsck + +def :: [Command] +def = [notDirect $ + command "migrate" paramPaths seek + SectionUtility "switch data to different backend"] + +seek :: [CommandSeek] +seek = [withFilesInGit $ whenAnnexed start] + +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, oldbackend) = do + exists <- inAnnex key + newbackend <- choosebackend =<< chooseBackend file + if (newbackend /= oldbackend || upgradableKey oldbackend key) && exists + then do + showStart "migrate" file + next $ perform file key oldbackend newbackend + else stop + where + choosebackend Nothing = Prelude.head <$> orderedList + choosebackend (Just backend) = return backend + +{- Checks if a key is upgradable to a newer representation. + - + - Reasons for migration: + - - Ideally, all keys have file size metadata. Old keys may not. + - - Something has changed in the backend, such as a bug fix. + -} +upgradableKey :: Backend -> Key -> Bool +upgradableKey backend key = isNothing (Types.Key.keySize key) || backendupgradable + where + backendupgradable = maybe False (\a -> a key) + (Types.Backend.canUpgradeKey backend) + +{- Store the old backend's key in the new backend + - The old backend's key is not dropped from it, because there may + - be other files still pointing at that key. + - + - To ensure that the data we have for the old key is valid, it's + - fscked here. First we generate the new key. This ensures that the + - data cannot get corrupted after the fsck but before the new key is + - generated. + -} +perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform +perform file oldkey oldbackend newbackend = go =<< genkey + where + go Nothing = stop + go (Just newkey) = stopUnless checkcontent $ finish newkey + checkcontent = Command.Fsck.checkBackend oldbackend oldkey $ Just file + finish newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $ + next $ Command.ReKey.cleanup file oldkey newkey + genkey = do + content <- calcRepo $ gitAnnexLocation oldkey + let source = KeySource + { keyFilename = file + , contentLocation = content + , inodeCache = Nothing + } + liftM fst <$> genKey source (Just newbackend) 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 new file mode 100644 index 000000000..dc501ae0f --- /dev/null +++ b/Command/Move.hs @@ -0,0 +1,166 @@ +{- git-annex command + - + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Move where + +import Common.Annex +import Command +import qualified Command.Drop +import qualified Annex +import Annex.Content +import qualified Remote +import Annex.UUID +import Logs.Presence +import Logs.Transfer +import GitAnnex.Options +import Types.Key + +def :: [Command] +def = [withOptions moveOptions $ command "move" paramPaths seek + SectionCommon "move content of files to/from another repository"] + +moveOptions :: [Option] +moveOptions = fromToOptions ++ keyOptions + +seek :: [CommandSeek] +seek = + [ withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> + withKeyOptions (startKey to from True) $ + withFilesInGit $ whenAnnexed $ start to from True + ] + +start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart +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 = start' to from move Nothing + +start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart +start' to from move afile key = do + noAuto + case (from, to) of + (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" + where + noAuto = when move $ whenM (Annex.getState Annex.auto) $ error + "--auto is not supported for move" + +showMoveAction :: Bool -> Key -> AssociatedFile -> Annex () +showMoveAction True _ (Just file) = showStart "move" file +showMoveAction False _ (Just file) = showStart "copy" file +showMoveAction True key Nothing = showStart "move" (key2file key) +showMoveAction False key Nothing = showStart "copy" (key2file key) + +{- Moves (or copies) the content of an annexed file to a remote. + - + - If the remote already has the content, it is still removed from + - the current repository. + - + - Note that unlike drop, this does not honor annex.numcopies. + - A file's content can be moved even if there are insufficient copies to + - allow it to be dropped. + -} +toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart +toStart dest move afile key = do + u <- getUUID + ishere <- inAnnex key + if not ishere || u == Remote.uuid dest + then stop -- not here, so nothing to do + else do + showMoveAction move key afile + next $ toPerform dest move key afile +toPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform +toPerform dest move key afile = moveLock move key $ do + -- Checking the remote is expensive, so not done in the start step. + -- In fast mode, location tracking is assumed to be correct, + -- and an explicit check is not done, when copying. When moving, + -- it has to be done, to avoid inaverdent data loss. + fast <- Annex.getState Annex.fast + let fastcheck = fast && not move && not (Remote.hasKeyCheap dest) + isthere <- if fastcheck + then Right <$> expectedpresent + else Remote.hasKey dest key + case isthere of + Left err -> do + showNote err + stop + Right False -> do + showAction $ "to " ++ Remote.name dest + ok <- upload (Remote.uuid dest) key afile noRetry $ + Remote.storeKey dest key afile + if ok + then do + Remote.logStatus dest key InfoPresent + finish + else do + when fastcheck $ + warning "This could have failed because --fast is enabled." + stop + Right True -> do + unlessM expectedpresent $ + Remote.logStatus dest key InfoPresent + finish + where + finish + | move = do + removeAnnex key + next $ Command.Drop.cleanupLocal key + | otherwise = next $ return True + expectedpresent = do + remotes <- Remote.keyPossibilities key + return $ dest `elem` remotes + +{- Moves (or copies) the content of an annexed file from a remote + - to the current repository. + - + - If the current repository already has the content, it is still removed + - from the remote. + -} +fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart +fromStart src move afile key + | move = go + | otherwise = stopUnless (not <$> inAnnex key) go + where + go = stopUnless (fromOk src key) $ do + showMoveAction move key afile + next $ fromPerform src move key afile + +fromOk :: Remote -> Key -> Annex Bool +fromOk src key + | Remote.hasKeyCheap src = + either (const expensive) return =<< Remote.hasKey src key + | otherwise = expensive + where + expensive = do + u <- getUUID + remotes <- Remote.keyPossibilities key + return $ u /= Remote.uuid src && elem src remotes + +fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform +fromPerform src move key afile = moveLock move key $ + ifM (inAnnex key) + ( handle move True + , handle move =<< go + ) + where + go = download (Remote.uuid src) key afile noRetry $ \p -> do + showAction $ "from " ++ Remote.name src + getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p + handle _ False = stop -- failed + handle False True = next $ return True -- copy complete + handle True True = do -- finish moving + ok <- Remote.removeKey src key + next $ Command.Drop.cleanupRemote key src ok + +{- Locks a key in order for it to be moved. + - No lock is needed when a key is being copied. -} +moveLock :: Bool -> Key -> Annex a -> Annex a +moveLock True key a = lockContent key a +moveLock False _ a = a diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs new file mode 100644 index 000000000..f10ac628e --- /dev/null +++ b/Command/PreCommit.hs @@ -0,0 +1,57 @@ +{- git-annex command + - + - Copyright 2010, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.PreCommit where + +import Common.Annex +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 + "run by git pre-commit hook"] + +seek :: [CommandSeek] +seek = + -- fix symlinks to files being committed + [ whenNotDirect $ withFilesToBeCommitted $ whenAnnexed Command.Fix.start + -- inject unlocked files into the annex + , whenNotDirect $ withFilesUnlockedToBeCommitted startIndirect + -- update direct mode mappings for committed files + , whenDirect $ withWords startDirect + ] + +startIndirect :: FilePath -> CommandStart +startIndirect file = next $ do + unlessM (doCommand $ Command.Add.start file) $ + error $ "failed to add " ++ file ++ "; canceling commit" + next $ return True + +startDirect :: [String] -> CommandStart +startDirect _ = next $ do + (diffs, clean) <- inRepo $ Git.DiffTree.diffIndex Git.Ref.headRef + makeabs <- flip fromTopFilePath <$> gitRepo + forM_ diffs (go makeabs) + next $ liftIO clean + where + 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 mode a = when (sha /= nullSha) $ do + k <- catKey sha mode + case k of + Nothing -> noop + Just key -> void $ a key $ + makeabs $ Git.DiffTree.file diff diff --git a/Command/ReKey.hs b/Command/ReKey.hs new file mode 100644 index 000000000..7448ba97e --- /dev/null +++ b/Command/ReKey.hs @@ -0,0 +1,71 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.ReKey where + +import Common.Annex +import Command +import qualified Annex +import Types.Key +import Annex.Content +import qualified Command.Add +import Logs.Web +import Logs.Location +import Utility.CopyFile + +def :: [Command] +def = [notDirect $ command "rekey" + (paramOptional $ paramRepeating $ paramPair paramPath paramKey) + seek SectionPlumbing "change keys used for files"] + +seek :: [CommandSeek] +seek = [withPairs start] + +start :: (FilePath, String) -> CommandStart +start (file, keyname) = ifAnnexed file go stop + where + newkey = fromMaybe (error "bad key") $ file2key keyname + go (oldkey, _) + | oldkey == newkey = stop + | otherwise = do + showStart "rekey" file + next $ perform file oldkey newkey + +perform :: FilePath -> Key -> Key -> CommandPerform +perform file oldkey newkey = do + present <- inAnnex oldkey + _ <- if present + then linkKey oldkey newkey + else do + unlessM (Annex.getState Annex.force) $ + error $ file ++ " is not available (use --force to override)" + return True + next $ cleanup file oldkey newkey + +{- Make a hard link to the old key content (when supported), + - to avoid wasting disk space. -} +linkKey :: Key -> Key -> Annex Bool +linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do + src <- calcRepo $ gitAnnexLocation oldkey + liftIO $ ifM (doesFileExist tmp) + ( return True + , createLinkOrCopy src tmp + ) + +cleanup :: FilePath -> Key -> Key -> CommandCleanup +cleanup file oldkey newkey = do + -- If the old key had some associated urls, record them for + -- the new key as well. + urls <- getUrls oldkey + unless (null urls) $ + mapM_ (setUrlPresent newkey) urls + + -- Update symlink to use the new key. + liftIO $ removeFile file + Command.Add.addLink file newkey Nothing + logStatus newkey InfoPresent + return True diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs new file mode 100644 index 000000000..3b2a8c496 --- /dev/null +++ b/Command/RecvKey.hs @@ -0,0 +1,89 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.RecvKey where + +import System.PosixCompat.Files + +import Common.Annex +import Command +import CmdLine +import Annex.Content +import Annex +import Utility.Rsync +import Logs.Transfer +import Command.SendKey (fieldTransfer) +import qualified Fields +import qualified Types.Key +import qualified Types.Backend +import qualified Backend + +def :: [Command] +def = [noCommit $ command "recvkey" paramKey seek + SectionPlumbing "runs rsync in server mode to receive content"] + +seek :: [CommandSeek] +seek = [withKeys start] + +start :: Key -> CommandStart +start key = ifM (inAnnex key) + ( error "key is already present in annex" + , fieldTransfer Download key $ \_p -> + ifM (getViaTmp key go) + ( do + -- forcibly quit after receiving one key, + -- and shutdown cleanly + _ <- shutdown True + return True + , return False + ) + ) + where + go tmp = do + opts <- filterRsyncSafeOptions . maybe [] words + <$> getField "RsyncOptions" + ok <- liftIO $ rsyncServerReceive (map Param opts) tmp + + -- The file could have been received with permissions that + -- do not allow reading it, so this is done before the + -- directcheck. + freezeContent tmp + + if ok + then ifM (isJust <$> Fields.getField Fields.direct) + ( directcheck tmp + , return True + ) + else return False + {- If the sending repository uses direct mode, the file + - it sends could be modified as it's sending it. So check + - that the right size file was received, and that the key/value + - Backend is happy with it. -} + directcheck tmp = do + oksize <- case Types.Key.keySize key of + Nothing -> return True + Just size -> do + size' <- fromIntegral . fileSize + <$> liftIO (getFileStatus tmp) + return $ size == size' + if oksize + then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of + 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 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 new file mode 100644 index 000000000..c49af0060 --- /dev/null +++ b/Command/Reinject.hs @@ -0,0 +1,58 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Reinject where + +import Common.Annex +import Command +import Logs.Location +import Annex.Content +import qualified Command.Fsck + +def :: [Command] +def = [command "reinject" (paramPair "SRC" "DEST") seek + SectionUtility "sets content of annexed file"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [FilePath] -> CommandStart +start (src:dest:[]) + | src == dest = stop + | otherwise = + ifAnnexed src + (error $ "cannot used annexed file as src: " ++ src) + go + where + go = do + showStart "reinject" dest + next $ whenAnnexed (perform src) dest +start _ = error "specify a src file and a dest file" + +perform :: FilePath -> FilePath -> (Key, Backend) -> CommandPerform +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) + ( do + unlessM move $ error "mv failed!" + next $ cleanup key + , error "not reinjecting" + ) + where + -- the file might be on a different filesystem, + -- so mv is used rather than simply calling + -- moveToObjectDir; disk space is also + -- checked this way. + move = getViaTmp key $ \tmp -> + liftIO $ boolSystem "mv" [File src, File tmp] + reject = const $ return "wrong file?" + +cleanup :: Key -> CommandCleanup +cleanup key = do + logStatus key InfoPresent + return True 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/RmUrl.hs b/Command/RmUrl.hs new file mode 100644 index 000000000..d3ded38a3 --- /dev/null +++ b/Command/RmUrl.hs @@ -0,0 +1,30 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.RmUrl where + +import Common.Annex +import Command +import Logs.Web + +def :: [Command] +def = [notBareRepo $ + command "rmurl" (paramPair paramFile paramUrl) seek + SectionCommon "record file is not available at url"] + +seek :: [CommandSeek] +seek = [withPairs start] + +start :: (FilePath, String) -> CommandStart +start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do + showStart "rmurl" file + next $ next $ cleanup url key + +cleanup :: String -> Key -> CommandCleanup +cleanup url key = do + setUrlMissing key url + return True 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/Semitrust.hs b/Command/Semitrust.hs new file mode 100644 index 000000000..e20563672 --- /dev/null +++ b/Command/Semitrust.hs @@ -0,0 +1,32 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Semitrust where + +import Common.Annex +import Command +import qualified Remote +import Logs.Trust + +def :: [Command] +def = [command "semitrust" (paramRepeating paramRemote) seek + SectionSetup "return repository to default trust level"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ws = do + let name = unwords ws + showStart "semitrust" name + u <- Remote.nameToUUID name + next $ perform u + +perform :: UUID -> CommandPerform +perform uuid = do + trustSet uuid SemiTrusted + next $ return True diff --git a/Command/SendKey.hs b/Command/SendKey.hs new file mode 100644 index 000000000..24b1821c3 --- /dev/null +++ b/Command/SendKey.hs @@ -0,0 +1,49 @@ +{- git-annex command + - + - Copyright 2010,2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.SendKey where + +import Common.Annex +import Command +import Annex.Content +import Annex +import Utility.Rsync +import Logs.Transfer +import qualified Fields +import Utility.Metered + +def :: [Command] +def = [noCommit $ command "sendkey" paramKey seek + SectionPlumbing "runs rsync in server mode to send content"] + +seek :: [CommandSeek] +seek = [withKeys start] + +start :: Key -> CommandStart +start key = do + opts <- filterRsyncSafeOptions . maybe [] words + <$> getField "RsyncOptions" + ifM (inAnnex key) + ( fieldTransfer Upload key $ \_p -> + sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts) + , do + warning "requested key is not present" + liftIO exitFailure + ) + where + {- No need to do any rollback; when sendAnnex fails, a nonzero + - exit will be propigated, and the remote will know the transfer + - failed. -} + rollback = noop + +fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart +fieldTransfer direction key a = do + afile <- Fields.getField Fields.associatedFile + ok <- maybe (a $ const noop) + (\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a) + =<< Fields.getField Fields.remoteUUID + liftIO $ exitBool ok diff --git a/Command/Status.hs b/Command/Status.hs new file mode 100644 index 000000000..5dc625994 --- /dev/null +++ b/Command/Status.hs @@ -0,0 +1,89 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Status where + +import Common.Annex +import Command +import Annex.CatFile +import Annex.Content.Direct +import Config +import qualified Git.LsFiles as LsFiles +import qualified Git.Ref +import qualified Git + +def :: [Command] +def = [notBareRepo $ noCommit $ noMessages $ + command "status" paramPaths seek SectionCommon + "show the working tree status"] + +seek :: [CommandSeek] +seek = + [ withWords start + ] + +start :: [FilePath] -> CommandStart +start [] = do + -- 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 + +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 + 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 + +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 new file mode 100644 index 000000000..c41f46f8a --- /dev/null +++ b/Command/Sync.hs @@ -0,0 +1,450 @@ +{- git-annex command + - + - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de> + - Copyright 2011,2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Sync where + +import Common.Annex +import Command +import qualified Remote +import qualified Annex +import qualified Annex.Branch +import qualified Annex.Queue +import Annex.Direct +import Annex.CatFile +import Annex.Link +import qualified Git.Command +import qualified Git.LsFiles as LsFiles +import qualified Git.Merge +import qualified Git.Branch +import qualified Git.Ref +import qualified Git +import Git.Types (BlobType(..)) +import qualified Types.Remote +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)) + [seek] SectionCommon "synchronize local repository with remotes"] + +-- syncing involves several operations, any of which can independently fail +seek :: CommandSeek +seek rs = do + 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 ] + , [ withbranch mergeLocal ] + , [ withbranch (pullRemote remote) | remote <- remotes ] + , [ mergeAnnex ] + , [ withbranch pushLocal ] + , [ withbranch (pushRemote remote) | remote <- remotes ] + ] + +{- 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" . fromDirectBranch + +remoteBranch :: Remote -> Git.Ref -> Git.Ref +remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote + +syncRemotes :: [String] -> Annex [Remote] +syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) + where + pickfast = (++) <$> listed <*> (good =<< fastest <$> available) + wanted + | null rs = good =<< concat . Remote.byCost <$> available + | otherwise = listed + listed = do + l <- catMaybes <$> mapM (Remote.byName . Just) rs + 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 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 $ 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 ++ + [Param "-m", Param "git-annex automatic sync"] + _ <- inRepo $ tryIO . Git.Command.runQuiet params + return True + +mergeLocal :: Maybe Git.Ref -> CommandStart +mergeLocal Nothing = stop +mergeLocal (Just branch) = go =<< needmerge + where + syncbranch = syncBranch branch + 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 :: 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 () +updateBranch syncbranch g = + unlessM go $ error $ "failed to update " ++ show syncbranch + where + go = Git.Command.runBool + [ Param "branch" + , Param "-f" + , Param $ show $ Git.Ref.base syncbranch + ] g + +pullRemote :: Remote -> Maybe Git.Ref -> CommandStart +pullRemote remote branch = do + showStart "pull" (Remote.name remote) + next $ do + showOutput + stopUnless fetch $ + next $ mergeRemote remote branch + where + fetch = inRepo $ Git.Command.runBool + [Param "fetch", Param $ Remote.name remote] + +{- The remote probably has both a master and a synced/master branch. + - Which to merge from? Well, the master has whatever latest changes + - 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 b = case b of + Nothing -> do + branch <- inRepo Git.Branch.currentUnsafe + 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 -> 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 + go True = do + showStart "push" (Remote.name remote) + next $ next $ do + showOutput + 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 + +{- 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 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 g) `after` syncpush g + where + 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 + ] ++ map Param branches + refspec b = concat + [ show $ Git.Ref.base b + , ":" + , show $ Git.Ref.base $ syncBranch b + ] + +mergeAnnex :: CommandStart +mergeAnnex = do + void Annex.Branch.forceUpdate + stop + +{- Merges from a branch into the current branch. -} +mergeFrom :: Git.Ref -> Annex Bool +mergeFrom branch = do + showOutput + ifM isDirect + ( maybe go godirect =<< inRepo Git.Branch.current + , go + ) + where + go = runmerge $ inRepo $ Git.Merge.mergeNonInteractive branch + godirect currbranch = do + old <- inRepo $ Git.Ref.sha currbranch + d <- fromRepo gitAnnexMergeDir + r <- runmerge $ inRepo $ mergeDirect d branch + new <- inRepo $ Git.Ref.sha currbranch + case (old, new) of + (Just oldsha, Just newsha) -> + mergeDirectCleanup d oldsha newsha + _ -> noop + return r + runmerge a = ifM a + ( return True + , resolveMerge + ) + +{- Resolves a conflicted merge. It's important that any conflicts be + - resolved in a way that itself avoids later merge conflicts, since + - multiple repositories may be doing this concurrently. + - + - Only annexed files are resolved; other files are left for the user to + - handle. + - + - 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.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.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]) + 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 (Maybe FilePath) +resolveMerge' u + | 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 + -- 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 + ) + 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 + file = LsFiles.unmergedFile u + 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 $ + toDirect key dest + 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. + - + - Something derived from the key needs to be included in the filename, + - but rather than exposing the whole key to the user, a very weak hash + - is used. There is a very real, although still unlikely, chance of + - conflicts using this hash. + - + - In the event that there is a conflict with the filename generated + - for some other key, that conflict will itself be handled by the + - conflicted merge resolution code. That case is detected, and the full + - key is used in the filename. + -} +mergeFile :: FilePath -> Key -> FilePath +mergeFile file key + | doubleconflict = go $ key2file key + | otherwise = go $ shortHash $ key2file key + where + varmarker = ".variant-" + doubleconflict = varmarker `isInfixOf` file + go v = takeDirectory file + </> dropExtension (takeFileName file) + ++ varmarker ++ v + ++ takeExtension file + +shortHash :: String -> String +shortHash = take 4 . md5s . md5FilePath + +changed :: Remote -> Git.Ref -> Annex Bool +changed remote b = do + let r = remoteBranch remote b + ifM (inRepo $ Git.Ref.exists r) + ( inRepo $ Git.Branch.changed b r + , return False + ) + +newer :: Remote -> Git.Ref -> Annex Bool +newer remote b = do + let r = remoteBranch remote b + ifM (inRepo $ Git.Ref.exists r) + ( inRepo $ Git.Branch.changed r b + , return True + ) diff --git a/Command/Test.hs b/Command/Test.hs new file mode 100644 index 000000000..bf15dcf50 --- /dev/null +++ b/Command/Test.hs @@ -0,0 +1,24 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Test where + +import Command + +def :: [Command] +def = [ dontCheck repoExists $ + command "test" paramNothing seek SectionPlumbing + "run built-in test suite"] + +seek :: [CommandSeek] +seek = [withWords start] + +{- We don't actually run the test suite here because of a dependency loop. + - The main program notices when the command is test and runs it; this + - function is never run if that works. -} +start :: [String] -> CommandStart +start _ = error "Cannot specify any additional parameters when running test" diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs new file mode 100644 index 000000000..93f6c7077 --- /dev/null +++ b/Command/TransferInfo.hs @@ -0,0 +1,64 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.TransferInfo where + +import Common.Annex +import Command +import Annex.Content +import Logs.Transfer +import Types.Key +import qualified Fields +import Utility.Metered + +def :: [Command] +def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing + "updates sender on number of bytes of content received"] + +seek :: [CommandSeek] +seek = [withWords start] + +{- Security: + - + - The transfer info file contains the user-supplied key, but + - the built-in guards prevent slashes in it from showing up in the filename. + - It also contains the UUID of the remote. But slashes are also filtered + - out of that when generating the filename. + - + - Checks that the key being transferred is inAnnex, to prevent + - malicious spamming of bogus keys. Does not check that a transfer + - of the key is actually in progress, because this could be started + - concurrently with sendkey, and win the race. + -} +start :: [String] -> CommandStart +start (k:[]) = do + case file2key k of + Nothing -> error "bad key" + (Just key) -> whenM (inAnnex key) $ do + file <- Fields.getField Fields.associatedFile + u <- maybe (error "missing remoteuuid") toUUID + <$> Fields.getField Fields.remoteUUID + let t = Transfer + { transferDirection = Upload + , transferUUID = u + , transferKey = key + } + info <- liftIO $ startTransferInfo file + (update, tfile, _) <- mkProgressUpdater t info + liftIO $ mapM_ void + [ tryIO $ forever $ do + bytes <- readUpdate + maybe (error "transferinfo protocol error") + (update . toBytesProcessed) bytes + , tryIO $ removeFile tfile + , exitSuccess + ] + stop +start _ = error "wrong number of parameters" + +readUpdate :: IO (Maybe Integer) +readUpdate = readish <$> getLine diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs new file mode 100644 index 000000000..5bb53d98d --- /dev/null +++ b/Command/TransferKey.hs @@ -0,0 +1,59 @@ +{- git-annex command, used internally by old versions of assistant; + - kept around for now so running daemons don't break when upgraded + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.TransferKey where + +import Common.Annex +import Command +import Annex.Content +import Logs.Location +import Logs.Transfer +import qualified Remote +import Types.Remote +import GitAnnex.Options +import qualified Option + +def :: [Command] +def = [withOptions transferKeyOptions $ + noCommit $ command "transferkey" paramKey seek SectionPlumbing + "transfers a key from or to a remote"] + +transferKeyOptions :: [Option] +transferKeyOptions = fileOption : fromToOptions + +fileOption :: Option +fileOption = Option.field [] "file" paramFile "the associated file" + +seek :: [CommandSeek] +seek = [withField toOption Remote.byNameWithUUID $ \to -> + withField fromOption Remote.byNameWithUUID $ \from -> + withField fileOption return $ \file -> + withKeys $ start to from file] + +start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart +start to from file key = + case (from, to) of + (Nothing, Just dest) -> next $ toPerform dest key file + (Just src, Nothing) -> next $ fromPerform src key file + _ -> error "specify either --from or --to" + +toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform +toPerform remote key file = go $ + upload (uuid remote) key file forwardRetry $ \p -> do + ok <- Remote.storeKey remote key file p + when ok $ + Remote.logStatus remote key InfoPresent + return ok + +fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform +fromPerform remote key file = go $ + download (uuid remote) key file forwardRetry $ \p -> + getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p + +go :: Annex Bool -> CommandPerform +go a = a >>= liftIO . exitBool diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs new file mode 100644 index 000000000..5ac9454aa --- /dev/null +++ b/Command/TransferKeys.hs @@ -0,0 +1,142 @@ +{- git-annex command, used internally by assistant + - + - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Command.TransferKeys where + +import Common.Annex +import Command +import Annex.Content +import Logs.Location +import Logs.Transfer +import qualified Remote +import Types.Key +import qualified Option + +data TransferRequest = TransferRequest Direction Remote Key AssociatedFile + +def :: [Command] +def = [withOptions options $ + command "transferkeys" paramNothing seek + SectionPlumbing "transfers keys"] + +options :: [Option] +options = [readFdOption, writeFdOption] + +readFdOption :: Option +readFdOption = Option.field [] "readfd" paramNumber "read from this fd" + +writeFdOption :: Option +writeFdOption = Option.field [] "writefd" paramNumber "write to this fd" + +seek :: [CommandSeek] +seek = [withField readFdOption convertFd $ \readh -> + withField writeFdOption convertFd $ \writeh -> + withNothing $ start readh writeh] + +convertFd :: Maybe String -> Annex (Maybe Handle) +convertFd Nothing = return Nothing +convertFd (Just s) = liftIO $ + case readish s of + Nothing -> error "bad fd" + Just fd -> Just <$> fdToHandle fd + +start :: Maybe Handle -> Maybe Handle -> CommandStart +start readh writeh = do + runRequests (fromMaybe stdin readh) (fromMaybe stdout writeh) runner + stop + where + runner (TransferRequest direction remote key file) + | direction == Upload = + upload (Remote.uuid remote) key file forwardRetry $ \p -> do + ok <- Remote.storeKey remote key file p + when ok $ + Remote.logStatus remote key InfoPresent + return ok + | otherwise = download (Remote.uuid remote) key file forwardRetry $ \p -> + getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p + +runRequests + :: Handle + -> Handle + -> (TransferRequest -> Annex Bool) + -> Annex () +runRequests readh writeh a = do + liftIO $ do + hSetBuffering readh NoBuffering + fileEncoding readh + fileEncoding writeh + go =<< readrequests + where + go (d:u:k:f:rest) = do + case (deserialize d, deserialize u, deserialize k, deserialize f) of + (Just direction, Just uuid, Just key, Just file) -> do + mremote <- Remote.remoteFromUUID uuid + case mremote of + Nothing -> sendresult False + Just remote -> sendresult =<< a + (TransferRequest direction remote key file) + _ -> sendresult False + go rest + go [] = noop + go [""] = noop + go v = error $ "transferkeys protocol error: " ++ show v + + readrequests = liftIO $ split fieldSep <$> hGetContents readh + sendresult b = liftIO $ do + hPutStrLn writeh $ serialize b + hFlush writeh + +sendRequest :: Transfer -> AssociatedFile -> Handle -> IO () +sendRequest t f h = do + hPutStr h $ intercalate fieldSep + [ serialize (transferDirection t) + , serialize (transferUUID t) + , serialize (transferKey t) + , serialize f + , "" -- adds a trailing null + ] + hFlush h + +readResponse :: Handle -> IO Bool +readResponse h = fromMaybe False . deserialize <$> hGetLine h + +fieldSep :: String +fieldSep = "\0" + +class Serialized a where + serialize :: a -> String + deserialize :: String -> Maybe a + +instance Serialized Bool where + serialize True = "1" + serialize False = "0" + deserialize "1" = Just True + deserialize "0" = Just False + deserialize _ = Nothing + +instance Serialized Direction where + serialize Upload = "u" + serialize Download = "d" + deserialize "u" = Just Upload + deserialize "d" = Just Download + deserialize _ = Nothing + +instance Serialized AssociatedFile where + serialize (Just f) = f + serialize Nothing = "" + deserialize "" = Just Nothing + deserialize f = Just $ Just f + +instance Serialized UUID where + serialize = fromUUID + deserialize = Just . toUUID + +instance Serialized Key where + serialize = key2file + deserialize = file2key diff --git a/Command/Trust.hs b/Command/Trust.hs new file mode 100644 index 000000000..26993ef77 --- /dev/null +++ b/Command/Trust.hs @@ -0,0 +1,32 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Trust where + +import Common.Annex +import Command +import qualified Remote +import Logs.Trust + +def :: [Command] +def = [command "trust" (paramRepeating paramRemote) seek + SectionSetup "trust a repository"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ws = do + let name = unwords ws + showStart "trust" name + u <- Remote.nameToUUID name + next $ perform u + +perform :: UUID -> CommandPerform +perform uuid = do + trustSet uuid Trusted + next $ return True diff --git a/Command/Unannex.hs b/Command/Unannex.hs new file mode 100644 index 000000000..5e3c4279a --- /dev/null +++ b/Command/Unannex.hs @@ -0,0 +1,98 @@ +{- git-annex command + - + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.Unannex where + +import Common.Annex +import Command +import Config +import qualified Annex +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 + "undo accidential add command"] + +seek :: [CommandSeek] +seek = [withFilesInGit $ whenAnnexed start] + +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, _) = stopUnless (inAnnex key) $ do + showStart "unannex" file + next $ ifM isDirect + ( performDirect file key + , performIndirect file key) + +performIndirect :: FilePath -> Key -> CommandPerform +performIndirect file key = do + liftIO $ removeFile file + + -- git rm deletes empty directory without --cached + inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file] + + -- If the file was already committed, it is now staged for removal. + -- Commit that removal now, to avoid later confusing the + -- pre-commit hook, if this file is later added back to + -- 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] + unless (null s) $ + inRepo $ Git.Command.run + [ Param "commit" + , Param "-q" + , Param "--no-verify" + , Param "-m", Param "content removed from git annex" + , Param "--", File file + ] + void $ liftIO reap + + next $ cleanupIndirect file key + +cleanupIndirect :: FilePath -> Key -> CommandCleanup +cleanupIndirect file key = do + src <- calcRepo $ gitAnnexLocation key + ifM (Annex.getState Annex.fast) + ( hardlinkfrom src + , copyfrom src + ) + where + 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) + ( return True + , copyfrom src + ) +#else + copyfrom src +#endif + +performDirect :: FilePath -> Key -> CommandPerform +performDirect file key = do + -- --force is needed when the file is not committed + inRepo $ Git.Command.run [Params "rm --cached --force --quiet --", File file] + next $ cleanupDirect file key + +{- The direct mode file is not touched during unannex, so the content + - is already where it needs to be, so this does not need to do anything + - except remove it from the associated file map (which also updates + - the location log if this was the last copy), and, if this was the last + - associated file, remove the inode cache. -} +cleanupDirect :: FilePath -> Key -> CommandCleanup +cleanupDirect file key = do + fs <- removeAssociatedFile key file + when (null fs) $ + removeInodeCache key + return True diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs new file mode 100644 index 000000000..a6557f21d --- /dev/null +++ b/Command/Ungroup.hs @@ -0,0 +1,35 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Ungroup where + +import Common.Annex +import Command +import qualified Remote +import Logs.Group +import Types.Group + +import qualified Data.Set as S + +def :: [Command] +def = [command "ungroup" (paramPair paramRemote paramDesc) seek + SectionSetup "remove a repository from a group"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start (name:g:[]) = do + showStart "ungroup" name + u <- Remote.nameToUUID name + next $ perform u g +start _ = error "Specify a repository and a group." + +perform :: UUID -> Group -> CommandPerform +perform uuid g = do + groupChange uuid (S.delete g) + next $ return True diff --git a/Command/Uninit.hs b/Command/Uninit.hs new file mode 100644 index 000000000..3fbe6758a --- /dev/null +++ b/Command/Uninit.hs @@ -0,0 +1,100 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Uninit where + +import Common.Annex +import Command +import qualified Git +import qualified Git.Command +import qualified Command.Unannex +import Init +import qualified Annex.Branch +import Annex.Content + +def :: [Command] +def = [addCheck check $ command "uninit" paramPaths seek + SectionUtility "de-initialize git-annex and clean out repository"] + +check :: Annex () +check = do + b <- current_branch + when (b == Annex.Branch.name) $ error $ + "cannot uninit when the " ++ show b ++ " branch is checked out" + top <- fromRepo Git.repoPath + cwd <- liftIO getCurrentDirectory + whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ + error "can only run uninit from the top of the git repository" + where + current_branch = Git.Ref . Prelude.head . lines <$> revhead + revhead = inRepo $ Git.Command.pipeReadStrict + [Params "rev-parse --abbrev-ref HEAD"] + +seek :: [CommandSeek] +seek = + [ withFilesNotInGit $ whenAnnexed startCheckIncomplete + , withFilesInGit $ whenAnnexed Command.Unannex.start + , withNothing start + ] + +{- git annex symlinks that are not checked into git could be left by an + - interrupted add. -} +startCheckIncomplete :: FilePath -> (Key, Backend) -> CommandStart +startCheckIncomplete file _ = error $ unlines + [ file ++ " points to annexed content, but is not checked into git." + , "Perhaps this was left behind by an interrupted git annex add?" + , "Not continuing with uninit; either delete or git annex add the file and retry." + ] + +start :: CommandStart +start = next $ next $ do + annexdir <- fromRepo gitAnnexDir + annexobjectdir <- fromRepo gitAnnexObjectDir + leftovers <- removeUnannexed =<< getKeysPresent + if null leftovers + then liftIO $ removeDirectoryRecursive annexdir + else error $ unlines + [ "Not fully uninitialized" + , "Some annexed data is still left in " ++ annexobjectdir + , "This may include deleted files, or old versions of modified files." + , "" + , "If you don't care about preserving the data, just delete the" + , "directory." + , "" + , "Or, you can move it to another location, in case it turns out" + , "something in there is important." + , "" + , "Or, you can run `git annex unused` followed by `git annex dropunused`" + , "to remove data that is not used by any tag or branch, which might" + , "take care of all the data." + , "" + , "Then run `git annex uninit` again to finish." + ] + uninitialize + -- avoid normal shutdown + saveState False + inRepo $ Git.Command.run + [Param "branch", Param "-D", Param $ show Annex.Branch.name] + liftIO exitSuccess + +{- Keys that were moved out of the annex have a hard link still in the + - annex, with > 1 link count, and those can be removed. + - + - Returns keys that cannot be removed. -} +removeUnannexed :: [Key] -> Annex [Key] +removeUnannexed = go [] + where + go c [] = return c + go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks) + ( do + removeAnnex k + go c ks + , go (k:c) ks + ) + enoughlinks f = catchBoolIO $ do + s <- getFileStatus f + return $ linkCount s > 1 diff --git a/Command/Unlock.hs b/Command/Unlock.hs new file mode 100644 index 000000000..1eba26ff7 --- /dev/null +++ b/Command/Unlock.hs @@ -0,0 +1,50 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Unlock where + +import Common.Annex +import Command +import Annex.Content +import Utility.CopyFile + +def :: [Command] +def = + [ c "unlock" "unlock files for modification" + , c "edit" "same as unlock" + ] + where + c n = notDirect . command n paramPaths seek SectionCommon + +seek :: [CommandSeek] +seek = [withFilesInGit $ whenAnnexed start] + +{- The unlock subcommand replaces the symlink with a copy of the file's + - content. -} +start :: FilePath -> (Key, Backend) -> CommandStart +start file (key, _) = do + showStart "unlock" file + next $ perform file key + +perform :: FilePath -> Key -> CommandPerform +perform dest key = do + unlessM (inAnnex key) $ error "content not present" + unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock" + + src <- calcRepo $ gitAnnexLocation key + tmpdest <- fromRepo $ gitAnnexTmpLocation key + liftIO $ createDirectoryIfMissing True (parentDir tmpdest) + showAction "copying" + ifM (liftIO $ copyFileExternal src tmpdest) + ( do + liftIO $ do + removeFile dest + moveFile tmpdest dest + thawContent dest + next $ return True + , error "copy failed!" + ) diff --git a/Command/Untrust.hs b/Command/Untrust.hs new file mode 100644 index 000000000..f18637838 --- /dev/null +++ b/Command/Untrust.hs @@ -0,0 +1,32 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Untrust where + +import Common.Annex +import Command +import qualified Remote +import Logs.Trust + +def :: [Command] +def = [command "untrust" (paramRepeating paramRemote) seek + SectionSetup "do not trust a repository"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start ws = do + let name = unwords ws + showStart "untrust" name + u <- Remote.nameToUUID name + next $ perform u + +perform :: UUID -> CommandPerform +perform uuid = do + trustSet uuid UnTrusted + next $ return True diff --git a/Command/Unused.hs b/Command/Unused.hs new file mode 100644 index 000000000..1e5cdc163 --- /dev/null +++ b/Command/Unused.hs @@ -0,0 +1,369 @@ +{- git-annex command + - + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Command.Unused where + +import qualified Data.Set as S +import qualified Data.ByteString.Lazy as L +import Data.BloomFilter +import Data.BloomFilter.Easy +import Data.BloomFilter.Hash +import Control.Monad.ST +import qualified Data.Map as M + +import Common.Annex +import Command +import Logs.Unused +import Annex.Content +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.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 + SectionMaintenance "look for unused file content"] + +fromOption :: Option +fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content" + +seek :: [CommandSeek] +seek = [withNothing start] + +{- Finds unused content in the annex. -} +start :: CommandStart +start = do + from <- Annex.getField $ Option.name fromOption + let (name, action) = case from of + Nothing -> (".", checkUnused) + Just "." -> (".", checkUnused) + Just "here" -> (".", checkUnused) + Just n -> (n, checkRemoteUnused n) + showStart "unused" name + next action + +checkUnused :: CommandPerform +checkUnused = chain 0 + [ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast + , check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir False + , check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpDir True + ] + where + findunused True = do + showNote "fast mode enabled; only finding stale files" + return [] + findunused False = do + showAction "checking for unused data" + excludeReferenced =<< getKeysPresent + chain _ [] = next $ return True + chain v (a:as) = do + v' <- a v + chain v' as + +checkRemoteUnused :: String -> CommandPerform +checkRemoteUnused name = go =<< fromJust <$> Remote.byNameWithUUID (Just name) + where + go r = do + showAction "checking for unused data" + _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 + next $ return True + remoteunused r = excludeReferenced <=< loggedKeysFor $ Remote.uuid r + +check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int +check file msg a c = do + l <- a + let unusedlist = number c l + unless (null l) $ showLongNote $ msg unusedlist + writeUnusedLog file unusedlist + return $ c + length l + +number :: Int -> [a] -> [(Int, a)] +number _ [] = [] +number n (x:xs) = (n+1, x) : number (n+1) xs + +table :: [(Int, Key)] -> [String] +table l = " NUMBER KEY" : map cols l + where + cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k + pad n s = s ++ replicate (n - length s) ' ' + +staleTmpMsg :: [(Int, Key)] -> String +staleTmpMsg t = unlines $ + ["Some partially transferred data exists in temporary files:"] + ++ table t ++ [dropMsg Nothing] + +staleBadMsg :: [(Int, Key)] -> String +staleBadMsg t = unlines $ + ["Some corrupted files have been preserved by fsck, just in case:"] + ++ table t ++ [dropMsg Nothing] + +unusedMsg :: [(Int, Key)] -> String +unusedMsg u = unusedMsg' u + ["Some annexed data is no longer used by any files:"] + [dropMsg Nothing] +unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String +unusedMsg' u header trailer = unlines $ + header ++ + table u ++ + ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ + trailer + +remoteUnusedMsg :: Remote -> [(Int, Key)] -> String +remoteUnusedMsg r u = unusedMsg' u + ["Some annexed data on " ++ name ++ " is not used by any files:"] + [dropMsg $ Just r] + where + name = Remote.name r + +dropMsg :: Maybe Remote -> String +dropMsg Nothing = dropMsg' "" +dropMsg (Just r) = dropMsg' $ " --from " ++ Remote.name r +dropMsg' :: String -> String +dropMsg' s = "\nTo remove unwanted data: git-annex dropunused" ++ s ++ " NUMBER\n" + +{- Finds keys in the list that are not referenced in the git repository. + - + - Strategy: + - + - * Build a bloom filter of all keys referenced by symlinks. This + - is the fastest one to build and will filter out most keys. + - * If keys remain, build a second bloom filter of keys referenced by + - all branches. + - * The list is streamed through these bloom filters lazily, so both will + - exist at the same time. This means that twice the memory is used, + - but they're relatively small, so the added complexity of using a + - mutable bloom filter does not seem worthwhile. + - * Generating the second bloom filter can take quite a while, since + - it needs enumerating all keys in all git branches. But, the common + - case, if the second filter is needed, is for some keys to be globally + - unused, and in that case, no short-circuit is possible. + - Short-circuiting if the first filter filters all the keys handles the + - other common case. + -} +excludeReferenced :: [Key] -> Annex [Key] +excludeReferenced ks = runfilter firstlevel ks >>= runfilter secondlevel + where + runfilter _ [] = return [] -- optimisation + runfilter a l = bloomFilter show l <$> genBloomFilter show a + firstlevel = withKeysReferencedM + secondlevel = withKeysReferencedInGit + +{- Finds items in the first, smaller list, that are not + - present in the second, larger list. + - + - Constructing a single set, of the list that tends to be + - smaller, appears more efficient in both memory and CPU + - than constructing and taking the S.difference of two sets. -} +exclude :: Ord a => [a] -> [a] -> [a] +exclude [] _ = [] -- optimisation +exclude smaller larger = S.toList $ remove larger $ S.fromList smaller + where + remove a b = foldl (flip S.delete) b a + +{- A bloom filter capable of holding half a million keys with a + - false positive rate of 1 in 1000 uses around 8 mb of memory, + - so will easily fit on even my lowest memory systems. + -} +bloomCapacity :: Annex Int +bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig +bloomAccuracy :: Annex Int +bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig +bloomBitsHashes :: Annex (Int, Int) +bloomBitsHashes = do + capacity <- bloomCapacity + accuracy <- bloomAccuracy + return $ suggestSizing capacity (1/ fromIntegral accuracy) + +{- Creates a bloom filter, and runs an action, such as withKeysReferenced, + - to populate it. + - + - The action is passed a callback that it can use to feed values into the + - bloom filter. + - + - Once the action completes, the mutable filter is frozen + - for later use. + -} +genBloomFilter :: Hashable t => (v -> t) -> ((v -> Annex ()) -> Annex b) -> Annex (Bloom t) +genBloomFilter convert populate = do + (numbits, numhashes) <- bloomBitsHashes + bloom <- lift $ newMB (cheapHashes numhashes) numbits + _ <- populate $ \v -> lift $ insertMB bloom (convert v) + lift $ unsafeFreezeMB bloom + where + lift = liftIO . stToIO + +bloomFilter :: Hashable t => (v -> t) -> [v] -> Bloom t -> [v] +bloomFilter convert l bloom = filter (\k -> convert k `notElemB` bloom) l + +{- Given an initial value, folds it with each key referenced by + - symlinks in the git repo. -} +withKeysReferenced :: v -> (Key -> v -> v) -> Annex v +withKeysReferenced initial a = withKeysReferenced' Nothing initial folda + where + folda k _ v = return $ a k v + +{- Runs an action on each referenced key in the git repo. -} +withKeysReferencedM :: (Key -> Annex ()) -> Annex () +withKeysReferencedM a = withKeysReferenced' Nothing () calla + where + calla k _ _ = a k + +{- Folds an action over keys and files referenced in a particular directory. -} +withKeysFilesReferencedIn :: FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysFilesReferencedIn = withKeysReferenced' . Just + +withKeysReferenced' :: Maybe FilePath -> v -> (Key -> FilePath -> v -> Annex v) -> Annex v +withKeysReferenced' mdir initial a = do + (files, clean) <- getfiles + r <- go initial files + liftIO $ void clean + return r + where + getfiles = case mdir of + Nothing -> ifM isBareRepo + ( return ([], return True) + , do + top <- fromRepo Git.repoPath + inRepo $ LsFiles.allFiles [top] + ) + Just dir -> inRepo $ LsFiles.inRepo [dir] + go v [] = return v + go v (f:fs) = do + x <- Backend.lookupFile f + case x of + Nothing -> go v fs + Just (k, _) -> do + !v' <- a k f v + go v' fs + +withKeysReferencedInGit :: (Key -> Annex ()) -> Annex () +withKeysReferencedInGit a = do + 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 headRef = addHead headRef . + filter ourbranches . + 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 + 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 + 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. + - + - Also, stale keys that can be proven to have no value are deleted. + -} +staleKeysPrune :: (Git.Repo -> FilePath) -> Bool -> Annex [Key] +staleKeysPrune dirspec nottransferred = do + contents <- dirKeys dirspec + + dups <- filterM inAnnex contents + let stale = contents `exclude` dups + + dir <- fromRepo dirspec + liftIO $ forM_ dups $ \t -> removeFile $ dir </> keyFile t + + if nottransferred + then do + inprogress <- S.fromList . map (transferKey . fst) + <$> getTransfers + return $ filter (`S.notMember` inprogress) stale + else return stale + +data UnusedMaps = UnusedMaps + { unusedMap :: UnusedMap + , unusedBadMap :: UnusedMap + , unusedTmpMap :: UnusedMap + } + +{- Read unused logs once, and pass the maps to each start action. -} +withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek +withUnusedMaps a params = do + unused <- readUnusedLog "" + unusedbad <- readUnusedLog "bad" + unusedtmp <- readUnusedLog "tmp" + let m = unused `M.union` unusedbad `M.union` unusedtmp + return $ map (a $ UnusedMaps unused unusedbad unusedtmp) $ + concatMap (unusedSpec m) params + +unusedSpec :: UnusedMap -> String -> [Int] +unusedSpec m spec + | spec == "all" = [fst (M.findMin m)..fst (M.findMax m)] + | "-" `isInfixOf` spec = range $ separate (== '-') spec + | otherwise = maybe badspec (: []) (readish spec) + where + range (a, b) = case (readish a, readish b) of + (Just x, Just y) -> [x..y] + _ -> badspec + badspec = error $ "Expected number or range, not \"" ++ spec ++ "\"" + +{- Start action for unused content. Finds the number in the maps, and + - calls either of 3 actions, depending on the type of unused file. -} +startUnused :: String + -> (Key -> CommandPerform) + -> (Key -> CommandPerform) + -> (Key -> CommandPerform) + -> UnusedMaps -> Int -> CommandStart +startUnused message unused badunused tmpunused maps n = search + [ (unusedMap maps, unused) + , (unusedBadMap maps, badunused) + , (unusedTmpMap maps, tmpunused) + ] + where + search [] = error $ show n ++ " not valid (run git annex unused for list)" + search ((m, a):rest) = + case M.lookup n m of + Nothing -> search rest + Just key -> do + showStart message (show n) + next $ a key diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs new file mode 100644 index 000000000..c6c0f7a8c --- /dev/null +++ b/Command/Upgrade.hs @@ -0,0 +1,28 @@ +{- git-annex command + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Upgrade where + +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 + command "upgrade" paramNothing seek + SectionMaintenance "upgrade repository layout"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + showStart "upgrade" "." + r <- upgrade False + next $ next $ return r diff --git a/Command/Version.hs b/Command/Version.hs new file mode 100644 index 000000000..b330d1ff1 --- /dev/null +++ b/Command/Version.hs @@ -0,0 +1,48 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Version where + +import Common.Annex +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 $ + command "version" paramNothing seek SectionQuery "show version info"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + v <- getVersion + liftIO $ do + showPackageVersion + 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 + 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 new file mode 100644 index 000000000..22c641408 --- /dev/null +++ b/Command/Vicfg.hs @@ -0,0 +1,213 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Vicfg where + +import qualified Data.Map as M +import qualified Data.Set as S +import System.Environment (getEnv) +import Data.Tuple (swap) +import Data.Char (isSpace) + +import Common.Annex +import Command +import Annex.Perms +import Types.TrustLevel +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] +def = [command "vicfg" paramNothing seek + SectionSetup "edit git-annex's configuration"] + +seek :: [CommandSeek] +seek = [withNothing start] + +start :: CommandStart +start = do + f <- fromRepo gitAnnexTmpCfgFile + createAnnexDirectory $ parentDir f + cfg <- getCfg + descs <- uuidDescriptions + liftIO $ writeFile f $ genCfg cfg descs + vicfg cfg f + stop + +vicfg :: Cfg -> FilePath -> Annex () +vicfg curcfg f = do + vi <- liftIO $ catchDefaultIO "vi" $ getEnv "EDITOR" + -- Allow EDITOR to be processed by the shell, so it can contain options. + unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ + error $ vi ++ " exited nonzero; aborting" + r <- parseCfg curcfg <$> liftIO (readFileStrict f) + liftIO $ nukeFile f + case r of + Left s -> do + liftIO $ writeFile f s + vicfg curcfg f + Right newcfg -> setCfg curcfg newcfg + +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 +getCfg = Cfg + <$> trustMapRaw -- without local trust overrides + <*> (groupsByUUID <$> groupMap) + <*> preferredContentMapRaw + <*> scheduleMap + +setCfg :: Cfg -> Cfg -> Annex () +setCfg curcfg newcfg = do + 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, 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, schedule] + where + intro = + [ com "git-annex configuration" + , com "" + , com "Changes saved to this file will be recorded in the git-annex branch." + , com "" + , com "Lines in this file have the format:" + , com " setting uuid = value" + ] + + trust = settings cfgTrustMap + [ "" + , com "Repository trust configuration" + , com "(Valid trust levels: " ++ trustlevels ++ ")" + ] + (\(t, u) -> line "trust" u $ showTrustLevel t) + (\u -> lcom $ line "trust" u $ showTrustLevel SemiTrusted) + where + trustlevels = unwords $ map showTrustLevel [Trusted .. DeadTrusted] + + groups = settings cfgGroupMap + [ "" + , com "Repository groups" + , com $ "(Standard groups: " ++ grouplist ++ ")" + , com "(Separate group names with spaces)" + ] + (\(s, u) -> line "group" u $ unwords $ S.toList s) + (\u -> lcom $ line "group" u "") + where + grouplist = unwords $ map fromStandardGroup [minBound..] + + preferredcontent = settings cfgPreferredContentMap + [ "" + , com "Repository preferred contents" + ] + (\(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 (lcom . showdefaults) $ missing field + ] + + line setting u value = + [ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")" + , unwords [setting, fromUUID u, "=", value] + ] + 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, + - with the problem lines noted. -} +parseCfg :: Cfg -> String -> Either String Cfg +parseCfg curcfg = go [] curcfg . lines + where + go c 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 + Left msg -> go ((Just msg, l):c) cfg ls + Right cfg' -> go ((Nothing, l):c) cfg' ls + + parse l cfg + | null l = Right cfg + | "#" `isPrefixOf` l = Right cfg + | null setting || null u = Left "missing repository uuid" + | otherwise = handle cfg (toUUID u) setting value' + where + (setting, rest) = separate isSpace l + (r, value) = separate (== '=') rest + value' = trimspace value + u = reverse $ trimspace $ reverse $ trimspace r + trimspace = dropWhile isSpace + + handle cfg u setting value + | setting == "trust" = case readTrustLevel value of + Nothing -> badval "trust value" value + Just t -> + let m = M.insert u t (cfgTrustMap cfg) + in Right $ cfg { cfgTrustMap = m } + | setting == "group" = + let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg) + in Right $ cfg { cfgGroupMap = m } + | setting == "content" = + case checkPreferredContentExpression value of + Just e -> Left e + 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] + showerr (Nothing, l) + -- filter out the header and parse error lines + -- from any previous parse failure + | any (`isPrefixOf` l) (parseerr:badheader) = [] + | otherwise = [l] + + badval desc val = Left $ "unknown " ++ desc ++ " \"" ++ val ++ "\"" + badheader = + [ com "There was a problem parsing your input." + , com "Search for \"Parse error\" to find the bad lines." + , com "Either fix the bad lines, or delete them (to discard your changes)." + ] + parseerr = com "Parse error in next line: " + +com :: String -> String +com s = "# " ++ s diff --git a/Command/Wanted.hs b/Command/Wanted.hs new file mode 100644 index 000000000..a7b4a3d9e --- /dev/null +++ b/Command/Wanted.hs @@ -0,0 +1,48 @@ +{- git-annex command + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Wanted where + +import Common.Annex +import Command +import qualified Remote +import Logs.PreferredContent + +import qualified Data.Map as M + +def :: [Command] +def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek + SectionSetup "get or set preferred content expression"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start = parse + where + parse (name:[]) = go name performGet + parse (name:expr:[]) = go name $ \uuid -> do + showStart "wanted" 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 + m <- preferredContentMapRaw + liftIO $ putStrLn $ fromMaybe "" $ M.lookup uuid m + next $ return True + +performSet :: String -> UUID -> CommandPerform +performSet expr uuid = case checkPreferredContentExpression expr of + Just e -> error $ "Parse error: " ++ e + Nothing -> do + preferredContentSet uuid expr + next $ return True diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 index 000000000..a33fc633c --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,36 @@ +{- git-annex watch command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Watch where + +import Common.Annex +import Assistant +import Command +import Option +import Utility.HumanTime + +def :: [Command] +def = [notBareRepo $ withOptions [foregroundOption, stopOption] $ + command "watch" paramNothing seek SectionCommon "watch for changes"] + +seek :: [CommandSeek] +seek = [withFlag stopOption $ \stopdaemon -> + withFlag foregroundOption $ \foreground -> + withNothing $ start False foreground stopdaemon Nothing] + +foregroundOption :: Option +foregroundOption = Option.flag [] "foreground" "do not daemonize" + +stopOption :: Option +stopOption = Option.flag [] "stop" "stop daemon" + +start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart +start assistant foreground stopdaemon startdelay = do + if stopdaemon + then stopDaemon + else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return + stop diff --git a/Command/WebApp.hs b/Command/WebApp.hs new file mode 100644 index 000000000..70f28a113 --- /dev/null +++ b/Command/WebApp.hs @@ -0,0 +1,226 @@ +{- git-annex webapp launcher + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Command.WebApp where + +import Common.Annex +import Command +import Assistant +import Assistant.Common +import Assistant.NamedThread +import Assistant.Threads.WebApp +import Assistant.WebApp +import Assistant.Install +import Annex.Environment +import Utility.WebApp +import Utility.Daemon (checkDaemon) +#ifdef __ANDROID__ +import Utility.Env +#endif +import Init +import qualified Git +import qualified Git.Config +import qualified Git.CurrentRepo +import qualified Annex +import Config.Files +import qualified Option +import Upgrade +import Annex.Version + +import Control.Concurrent +import Control.Concurrent.STM +import System.Process (env, std_out, std_err) +import Network.Socket (HostName) +import System.Environment (getArgs) + +def :: [Command] +def = [ withOptions [listenOption] $ + noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ + command "webapp" paramNothing seek SectionCommon "launch webapp"] + +listenOption :: Option +listenOption = Option.field [] "listen" paramAddress + "accept connections to this address" + +seek :: [CommandSeek] +seek = [withField listenOption return $ \listenhost -> + withNothing $ start listenhost] + +start :: Maybe HostName -> CommandStart +start = start' True + +start' :: Bool -> Maybe HostName -> CommandStart +start' allowauto listenhost = do + liftIO ensureInstalled + ifM isInitialized + ( go + , auto + ) + stop + where + go = do + cannotrun <- needsUpgrade . fromMaybe (error "no version") =<< getVersion + browser <- fromRepo webBrowser + f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim + ifM (checkpid <&&> checkshim f) + ( if isJust listenhost + then error "The assistant is already running, so --listen cannot be used." + else do + url <- liftIO . readFile + =<< fromRepo gitAnnexUrlFile + liftIO $ openBrowser browser f url Nothing Nothing + , startDaemon True True Nothing cannotrun listenhost $ Just $ + \origout origerr url htmlshim -> + if isJust listenhost + then maybe noop (`hPutStrLn` url) origout + else openBrowser browser htmlshim url origout origerr + ) + auto + | allowauto = liftIO startNoRepo + | otherwise = do + d <- liftIO getCurrentDirectory + error $ "no git repository in " ++ d + checkpid = do + pidfile <- fromRepo gitAnnexPidFile + liftIO $ isJust <$> checkDaemon pidfile + checkshim f = liftIO $ doesFileExist f + +{- When run without a repo, start the first available listed repository in + - the autostart file. If not, it's our first time being run! -} +startNoRepo :: IO () +startNoRepo = do + -- FIXME should be able to reuse regular getopt, but + -- it currently runs in the Annex monad. + args <- getArgs + let listenhost = headMaybe $ map (snd . separate (== '=')) $ + filter ("--listen=" `isPrefixOf`) args + + dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile + case dirs of + [] -> firstRun listenhost + (d:_) -> do + setCurrentDirectory d + state <- Annex.new =<< Git.CurrentRepo.get + void $ Annex.eval state $ doCommand $ + start' False listenhost + +{- Run the webapp without a repository, which prompts the user, makes one, + - changes to it, starts the regular assistant, and redirects the + - browser to its url. + - + - This is a very tricky dance -- The first webapp calls the signaler, + - which signals the main thread when it's ok to continue by writing to a + - MVar. The main thread starts the second webapp, and uses its callback + - to write its url back to the MVar, from where the signaler retrieves it, + - returning it to the first webapp, which does the redirect. + - + - Note that it's important that mainthread never terminates! Much + - of this complication is due to needing to keep the mainthread running. + -} +firstRun :: Maybe HostName -> IO () +firstRun listenhost = do + checkEnvironmentIO + {- Without a repository, we cannot have an Annex monad, so cannot + - get a ThreadState. Using undefined is only safe because the + - webapp checks its noAnnex field before accessing the + - threadstate. -} + let st = undefined + {- Get a DaemonStatus without running in the Annex monad. -} + dstatus <- atomically . newTMVar =<< newDaemonStatus + d <- newAssistantData st dstatus + urlrenderer <- newUrlRenderer + v <- newEmptyMVar + let callback a = Just $ a v + runAssistant d $ do + startNamedThread urlrenderer $ + webAppThread d urlrenderer True Nothing listenhost + (callback signaler) + (callback mainthread) + waitNamedThreads + where + signaler v = do + putMVar v "" + takeMVar v + mainthread v url htmlshim + | isJust listenhost = do + putStrLn url + hFlush stdout + go + | otherwise = do + browser <- maybe Nothing webBrowser <$> Git.Config.global + openBrowser browser htmlshim url Nothing Nothing + go + where + go = do + _wait <- takeMVar v + state <- Annex.new =<< Git.CurrentRepo.get + Annex.eval state $ + startDaemon True True Nothing Nothing listenhost $ Just $ + sendurlback v + sendurlback v _origout _origerr url _htmlshim = do + recordUrl url + putMVar v url + +recordUrl :: String -> IO () +#ifdef __ANDROID__ +{- The Android app has a menu item that opens the url recorded + - in this file. -} +recordUrl url = writeFile "/sdcard/git-annex.home/.git-annex-url" url +#else +recordUrl _ = noop +#endif + +openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () +#ifndef __ANDROID__ +openBrowser mcmd htmlshim _realurl outh errh = runbrowser +#else +openBrowser mcmd htmlshim realurl outh errh = do + recordUrl url + {- Android's `am` command does not work reliably across the + - wide range of Android devices. Intead, FIFO should be set to + - the filename of a fifo that we can write the URL to. -} + v <- getEnv "FIFO" + case v of + Nothing -> runbrowser + Just f -> void $ forkIO $ do + fd <- openFd f WriteOnly Nothing defaultFileFlags + void $ fdWrite fd url + closeFd fd +#endif + where + p = case mcmd of + Just cmd -> proc cmd [htmlshim] + Nothing -> browserProc url +#ifdef __ANDROID__ + {- Android does not support file:// urls, but neither is + - the security of the url in the process table important + - there, so just use the real url. -} + url = realurl +#else + url = fileUrl htmlshim +#endif + runbrowser = do + hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url + hFlush stdout + environ <- cleanEnvironment + (_, _, _, pid) <- createProcess p + { env = environ + , std_out = maybe Inherit UseHandle outh + , std_err = maybe Inherit UseHandle errh + } + exitcode <- waitForProcess pid + 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 -} +webBrowser :: Git.Repo -> Maybe FilePath +webBrowser = Git.Config.getMaybe "web.browser" + +fileUrl :: FilePath -> String +fileUrl file = "file://" ++ file diff --git a/Command/Whereis.hs b/Command/Whereis.hs new file mode 100644 index 000000000..7086bf645 --- /dev/null +++ b/Command/Whereis.hs @@ -0,0 +1,54 @@ +{- git-annex command + - + - Copyright 2010 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Whereis where + +import qualified Data.Map as M + +import Common.Annex +import Command +import Remote +import Logs.Trust + +def :: [Command] +def = [noCommit $ command "whereis" paramPaths seek + SectionQuery "lists repositories that have file content"] + +seek :: [CommandSeek] +seek = [withValue (remoteMap id) $ \m -> + withFilesInGit $ whenAnnexed $ start m] + +start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart +start remotemap file (key, _) = do + showStart "whereis" file + next $ perform remotemap key + +perform :: M.Map UUID Remote -> Key -> CommandPerform +perform remotemap key = do + locations <- keyLocations key + (untrustedlocations, safelocations) <- trustPartition UnTrusted locations + let num = length safelocations + showNote $ show num ++ " " ++ copiesplural num + pp <- prettyPrintUUIDs "whereis" safelocations + unless (null safelocations) $ showLongNote pp + pp' <- prettyPrintUUIDs "untrusted" untrustedlocations + unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp' + forM_ (mapMaybe (`M.lookup` remotemap) locations) $ + performRemote key + if null safelocations then stop else next $ return True + where + copiesplural 1 = "copy" + copiesplural _ = "copies" + untrustedheader = "The following untrusted locations may also have copies:\n" + +performRemote :: Key -> Remote -> Annex () +performRemote key remote = maybe noop go $ whereisKey remote + where + go a = do + ls <- a key + unless (null ls) $ showLongNote $ unlines $ + map (\l -> name remote ++ ": " ++ l) ls diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs new file mode 100644 index 000000000..c1ff0b108 --- /dev/null +++ b/Command/XMPPGit.hs @@ -0,0 +1,43 @@ +{- git-annex command + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.XMPPGit where + +import Common.Annex +import Command +import Assistant.XMPP.Git + +def :: [Command] +def = [noCommit $ noRepo xmppGitRelay $ dontCheck repoExists $ + command "xmppgit" paramNothing seek + SectionPlumbing "git to XMPP relay"] + +seek :: [CommandSeek] +seek = [withWords start] + +start :: [String] -> CommandStart +start _ = do + liftIO gitRemoteHelper + liftIO xmppGitRelay + stop + +{- A basic implementation of the git-remote-helpers protocol. -} +gitRemoteHelper :: IO () +gitRemoteHelper = do + expect "capabilities" + respond ["connect"] + expect "connect git-receive-pack" + respond [] + where + expect s = do + cmd <- getLine + unless (cmd == s) $ + error $ "git-remote-helpers protocol error: expected: " ++ s ++ ", but got: " ++ cmd + respond l = do + mapM_ putStrLn l + putStrLn "" + hFlush stdout |