From df5e2e3d656a8acf467043588422b34eaf1ffd04 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 19 Jan 2014 19:18:33 -0400 Subject: [PATCH 01/16] gathd --- doc/design/assistant/telehash.mdwn | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn index 9e1d6f613d..01cbd1340c 100644 --- a/doc/design/assistant/telehash.mdwn +++ b/doc/design/assistant/telehash.mdwn @@ -58,3 +58,31 @@ This might turn out to be easy to split off from git-annex, so `git pull` and `git push` can be used at the command line to access telehash remotes. Allows using general git entirely decentralized and with end-to-end encryption. + +## separate daemon? + +A `gathd` could contain all the telehash specific code, and git-annex +communicate with it via a local socket. + +Advantages: + +* `git annex sync` could also use the running daemon +* `git-remote-telehash` could use the running daemon +* c-telehash might end up linked to openssl, which has licence combination + problems with git-annex. A separate process not using git-annex's code + would avoid this. +* Allows the daemon to be written in some other language if necessary + (for example, if c-telehash development stalls and the nodejs version is + already usable) +* Potentially could be generalized to handle other similar protocols. + Or even the xmpp code moved into it. +* Security holes in telehash would not need to compromise the entire + git-annex. gathd could be sandboxed in one way or another. + +Disadvantages: + +* Adds a memcopy when large files are being transferred through telehash. + Unlikely to be a bottleneck. +* Adds some complexity. +* What IPC to use on Windows? Might have to make git-annex communicate + with it over its stdin/stdout there. From 34c8af74ba8f0e49709a2cbb0a172e4aeeeb3285 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 04:11:42 -0400 Subject: [PATCH 02/16] fix inversion of control in CommandSeek (no behavior changes) I've been disliking how the command seek actions were written for some time, with their inversion of control and ugly workarounds. The last straw to fix it was sync --content, which didn't fit the Annex [CommandStart] interface well at all. I have not yet made it take advantage of the changed interface though. The crucial change, and probably why I didn't do it this way from the beginning, is to make each CommandStart action be run with exceptions caught, and if it fails, increment a failure counter in annex state. So I finally remove the very first code I wrote for git-annex, which was before I had exception handling in the Annex monad, and so ran outside that monad, passing state explicitly as it ran each CommandStart action. This was a real slog from 1 to 5 am. Test suite passes. Memory usage is lower than before, sometimes by a couple of megabytes, and remains constant, even when running in a large repo, and even when repeatedly failing and incrementing the error counter. So no accidental laziness space leaks. Wall clock speed is identical, even in large repos. This commit was sponsored by an anonymous bitcoiner. --- Annex.hs | 2 + Annex/Drop.hs | 2 +- CmdLine.hs | 45 +++++----------------- Command.hs | 29 +++------------ Command/Add.hs | 24 ++++++------ Command/AddUnused.hs | 4 +- Command/AddUrl.hs | 11 +++--- Command/Assistant.hs | 13 ++++--- Command/Commit.hs | 4 +- Command/ConfigList.hs | 4 +- Command/Copy.hs | 15 ++++---- Command/Dead.hs | 4 +- Command/Describe.hs | 4 +- Command/Direct.hs | 4 +- Command/Drop.hs | 7 ++-- Command/DropKey.hs | 4 +- Command/DropUnused.hs | 4 +- Command/EnableRemote.hs | 4 +- Command/ExamineKey.hs | 8 ++-- Command/Find.hs | 10 +++-- Command/Fix.hs | 4 +- Command/Forget.hs | 7 ++-- Command/FromKey.hs | 4 +- Command/Fsck.hs | 19 +++++----- Command/FuzzTest.hs | 4 +- Command/GCryptSetup.hs | 4 +- Command/Get.hs | 13 ++++--- Command/Group.hs | 4 +- Command/Help.hs | 4 +- Command/Import.hs | 6 ++- Command/ImportFeed.hs | 11 +++--- Command/InAnnex.hs | 4 +- Command/Indirect.hs | 4 +- Command/Info.hs | 4 +- Command/Init.hs | 4 +- Command/InitRemote.hs | 4 +- Command/List.hs | 16 ++++---- Command/Lock.hs | 6 ++- Command/Log.hs | 13 ++++--- Command/LookupKey.hs | 4 +- Command/Map.hs | 4 +- Command/Merge.hs | 9 ++--- Command/Migrate.hs | 4 +- Command/Mirror.hs | 15 ++++---- Command/Move.hs | 15 ++++---- Command/PreCommit.hs | 20 +++++----- Command/ReKey.hs | 4 +- Command/RecvKey.hs | 4 +- Command/Reinject.hs | 4 +- Command/Repair.hs | 4 +- Command/RmUrl.hs | 4 +- Command/Schedule.hs | 4 +- Command/Semitrust.hs | 4 +- Command/SendKey.hs | 4 +- Command/Status.hs | 6 +-- Command/Sync.hs | 27 ++++++-------- Command/Test.hs | 4 +- Command/TransferInfo.hs | 4 +- Command/TransferKey.hs | 11 +++--- Command/TransferKeys.hs | 4 +- Command/Trust.hs | 4 +- Command/Unannex.hs | 4 +- Command/Ungroup.hs | 4 +- Command/Uninit.hs | 15 ++++---- Command/Unlock.hs | 4 +- Command/Untrust.hs | 4 +- Command/Unused.hs | 12 +++--- Command/Upgrade.hs | 4 +- Command/Version.hs | 4 +- Command/Vicfg.hs | 4 +- Command/Wanted.hs | 4 +- Command/Watch.hs | 9 +++-- Command/WebApp.hs | 9 +++-- Command/Whereis.hs | 7 ++-- Command/XMPPGit.hs | 4 +- GitAnnexShell.hs | 2 +- RunCommand.hs | 64 ++++++++++++++++++++++++++++++++ Seek.hs | 82 ++++++++++++++++++++--------------------- Types/Command.hs | 8 ++-- 79 files changed, 389 insertions(+), 355 deletions(-) create mode 100644 RunCommand.hs diff --git a/Annex.hs b/Annex.hs index 023ca88e9d..d8a2730ba0 100644 --- a/Annex.hs +++ b/Annex.hs @@ -109,6 +109,7 @@ data AnnexState = AnnexState , cleanup :: M.Map String (Annex ()) , inodeschanged :: Maybe Bool , useragent :: Maybe String + , errcounter :: Integer } newState :: GitConfig -> Git.Repo -> AnnexState @@ -143,6 +144,7 @@ newState c r = AnnexState , cleanup = M.empty , inodeschanged = Nothing , useragent = Nothing + , errcounter = 0 } {- Makes an Annex state object for the specified git repo. diff --git a/Annex/Drop.hs b/Annex/Drop.hs index df64895be4..3e915c315d 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -92,7 +92,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do checkdrop fs n@(have, numcopies, _untrusted) u a = ifM (allM (wantDrop True u . Just) fs) - ( ifM (safely $ doCommand $ a (Just numcopies)) + ( ifM (safely $ callCommand $ a (Just numcopies)) ( do liftIO $ debugM "drop" $ unwords [ "dropped" diff --git a/CmdLine.hs b/CmdLine.hs index 7c28ecec82..cba403dc20 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -23,7 +23,6 @@ import System.Posix.Signals import Common.Annex import qualified Annex -import qualified Annex.Queue import qualified Git import qualified Git.AutoCorrect import Annex.Content @@ -41,7 +40,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do Left e -> maybe (throw e) (\a -> a params) (cmdnorepo cmd) Right g -> do state <- Annex.new g - (actions, state') <- Annex.run state $ do + Annex.eval state $ do checkEnvironment checkfuzzy forM_ fields $ uncurry Annex.setField @@ -50,8 +49,9 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do sequence_ flags whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput - prepCommand cmd params - tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd] + startup + performCommand cmd params + shutdown $ cmdnocommit cmd where err msg = msg ++ "\n\n" ++ usage header allcmds cmd = Prelude.head cmds @@ -92,44 +92,19 @@ getOptCmd argv cmd commonoptions = check $ , commandUsage cmd ] -{- Runs a list of Annex actions. Catches IO errors and continues - - (but explicitly thrown errors terminate the whole command). - -} -tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO () -tryRun = tryRun' 0 -tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO () -tryRun' errnum _ cmd [] - | errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed" - | otherwise = noop -tryRun' errnum state cmd (a:as) = do - r <- run - handle $! r - where - run = tryIO $ Annex.run state $ do - Annex.Queue.flushWhenFull - a - handle (Left err) = showerr err >> cont False state - handle (Right (success, state')) = cont success state' - cont success s = do - let errnum' = if success then errnum else errnum + 1 - (tryRun' $! errnum') s cmd as - showerr err = Annex.eval state $ do - showErr err - showEndFail - {- Actions to perform each time ran. -} -startup :: Annex Bool -startup = liftIO $ do +startup :: Annex () +startup = #ifndef mingw32_HOST_OS - void $ installHandler sigINT Default Nothing + liftIO $ void $ installHandler sigINT Default Nothing +#else + return () #endif - return True {- Cleanup actions. -} -shutdown :: Bool -> Annex Bool +shutdown :: Bool -> Annex () shutdown nocommit = do saveState nocommit sequence_ =<< M.elems <$> Annex.getState Annex.cleanup liftIO reapZombies -- zombies from long-running git processes sshCleanup -- ssh connection caching - return True diff --git a/Command.hs b/Command.hs index b6484749ec..aeffbbeb8e 100644 --- a/Command.hs +++ b/Command.hs @@ -1,10 +1,12 @@ {- git-annex command infrastructure - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Command ( command, noRepo, @@ -14,8 +16,7 @@ module Command ( next, stop, stopUnless, - prepCommand, - doCommand, + runCommand, whenAnnexed, ifAnnexed, isBareRepo, @@ -35,12 +36,13 @@ import Types.Option as ReExported import Seek as ReExported import Checks as ReExported import Usage as ReExported +import RunCommand as ReExported import Logs.Trust import Config import Annex.CheckAttr {- Generates a normal command -} -command :: String -> String -> [CommandSeek] -> CommandSection -> String -> Command +command :: String -> String -> CommandSeek -> CommandSection -> String -> Command command = Command [] Nothing commonChecks False False {- Indicates that a command doesn't need to commit any changes to @@ -74,25 +76,6 @@ stop = return Nothing stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop ) -{- Prepares to run a command via the check and seek stages, returning a - - list of actions to perform to run the command. -} -prepCommand :: Command -> [String] -> Annex [CommandCleanup] -prepCommand Command { cmdseek = seek, cmdcheck = c } params = do - mapM_ runCheck c - map doCommand . concat <$> mapM (\s -> s params) seek - -{- Runs a command through the start, perform and cleanup stages -} -doCommand :: CommandStart -> CommandCleanup -doCommand = start - where - start = stage $ maybe skip perform - perform = stage $ maybe failure cleanup - cleanup = stage $ status - stage = (=<<) - skip = return True - failure = showEndFail >> return False - status r = showEndResult r >> return r - {- Modifies an action to only act on files that are already annexed, - and passes the key and backend on to it. -} whenAnnexed :: (FilePath -> (Key, Backend) -> Annex (Maybe a)) -> FilePath -> Annex (Maybe a) diff --git a/Command/Add.hs b/Command/Add.hs index c5035ba1fd..ffa27504a2 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -41,18 +41,18 @@ def = [notBareRepo $ command "add" paramPaths seek SectionCommon {- 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 - ) +seek :: CommandSeek +seek ps = do + matcher <- largeFilesMatcher + let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) + ( start file + , stop + ) + go withFilesNotInGit + ifM isDirect + ( go withFilesMaybeModified + , go withFilesUnlocked + ) {- 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 diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 1a178e8d47..91427e8191 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -18,8 +18,8 @@ def :: [Command] def = [notDirect $ command "addunused" (paramRepeating paramNumRange) seek SectionMaintenance "add back unused files"] -seek :: [CommandSeek] -seek = [withUnusedMaps start] +seek :: CommandSeek +seek = withUnusedMaps start start :: UnusedMaps -> Int -> CommandStart start = startUnused "addunused" perform diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 7f3607b816..8027c4b6bc 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -47,11 +47,12 @@ pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to us 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] +seek :: CommandSeek +seek ps = do + f <- getOptionField fileOption return + relaxed <- getOptionFlag relaxedOption + d <- getOptionField pathdepthOption (return . maybe Nothing readish) + withStrings (start relaxed f d) ps start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s diff --git a/Command/Assistant.hs b/Command/Assistant.hs index cef4392dc6..260d9c69c6 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -37,12 +37,13 @@ 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] +seek :: CommandSeek +seek ps = do + stopdaemon <- getOptionFlag Command.Watch.stopOption + foreground <- getOptionFlag Command.Watch.foregroundOption + autostart <- getOptionFlag autoStartOption + startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration) + withNothing (start foreground stopdaemon autostart startdelay) ps start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart start foreground stopdaemon autostart startdelay diff --git a/Command/Commit.hs b/Command/Commit.hs index 6f3f9df285..f5f13d248e 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "commit" paramNothing seek SectionPlumbing "commits any staged changes to the git-annex branch"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = next $ next $ do diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index c42480200b..58b7388645 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -17,8 +17,8 @@ def :: [Command] def = [noCommit $ command "configlist" paramNothing seek SectionPlumbing "outputs relevant git configuration"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Copy.hs b/Command/Copy.hs index 9fd97334ad..fd16cea29d 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -18,13 +18,14 @@ 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 - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (Command.Move.startKey to from False) + (withFilesInGit $ whenAnnexed $ start to from) + ps {- A copy is just a move that does not delete the source file. - However, --auto mode avoids unnecessary copies, and avoids getting or diff --git a/Command/Dead.hs b/Command/Dead.hs index 180f2fda90..13aa74bffa 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "dead" (paramRepeating paramRemote) seek SectionSetup "hide a lost repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Describe.hs b/Command/Describe.hs index 18851b1726..601b3fcc98 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "describe" (paramPair paramRemote paramDesc) seek SectionSetup "change description of a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:description) = do diff --git a/Command/Direct.hs b/Command/Direct.hs index c35bbdaea8..47f622a81a 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -23,8 +23,8 @@ def = [notBareRepo $ noDaemonRunning $ command "direct" paramNothing seek SectionSetup "switch repository to direct mode"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = ifM isDirect ( stop , next perform ) diff --git a/Command/Drop.hs b/Command/Drop.hs index 4c7128603d..f5c76f1ce8 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -27,9 +27,10 @@ def = [withOptions [fromOption] $ command "drop" paramPaths seek 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] +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + withFilesInGit (whenAnnexed $ start from) ps start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start from file (key, _) = checkDropAuto from file key $ \numcopies -> diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 6249195840..002633e582 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -18,8 +18,8 @@ def :: [Command] def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek SectionPlumbing "drops annexed content for specified keys"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = stopUnless (inAnnex key) $ do diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index bf2635e00f..5d7c5c1d23 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -21,8 +21,8 @@ def = [withOptions [Command.Drop.fromOption] $ command "dropunused" (paramRepeating paramNumRange) seek SectionMaintenance "drop unused file content"] -seek :: [CommandSeek] -seek = [withUnusedMaps start] +seek :: CommandSeek +seek = withUnusedMaps start start :: UnusedMaps -> Int -> CommandStart start = startUnused "dropunused" perform (performOther gitAnnexBadLocation) (performOther gitAnnexTmpLocation) diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index 1905acd8d8..a00046d5a5 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -20,8 +20,8 @@ def = [command "enableremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) seek SectionSetup "enables use of an existing special remote"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start [] = unknownNameError "Specify the name of the special remote to enable." diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 1e8e2cecf1..30963287e2 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -10,7 +10,7 @@ module Command.ExamineKey where import Common.Annex import Command import qualified Utility.Format -import Command.Find (formatOption, withFormat, showFormatted, keyVars) +import Command.Find (formatOption, getFormat, showFormatted, keyVars) import Types.Key import GitAnnex.Options @@ -19,8 +19,10 @@ def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $ command "examinekey" (paramRepeating paramKey) seek SectionPlumbing "prints information from a key"] -seek :: [CommandSeek] -seek = [withFormat $ \f -> withKeys $ start f] +seek :: CommandSeek +seek ps = do + format <- getFormat + withKeys (start format) ps start :: Maybe Utility.Format.Format -> Key -> CommandStart start format key = do diff --git a/Command/Find.hs b/Command/Find.hs index ddcc4b8c76..e7e5b79868 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -27,8 +27,8 @@ def = [noCommit $ noMessages $ withOptions [formatOption, print0Option, jsonOpti formatOption :: Option formatOption = Option.field [] "format" paramFormat "control format of output" -withFormat :: (Maybe Utility.Format.Format -> CommandSeek) -> CommandSeek -withFormat = withField formatOption $ return . fmap Utility.Format.gen +getFormat :: Annex (Maybe Utility.Format.Format) +getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen print0Option :: Option print0Option = Option.Option [] ["print0"] (Option.NoArg set) @@ -36,8 +36,10 @@ print0Option = Option.Option [] ["print0"] (Option.NoArg set) where set = Annex.setField (Option.name formatOption) "${file}\0" -seek :: [CommandSeek] -seek = [withFormat $ \f -> withFilesInGit $ whenAnnexed $ start f] +seek :: CommandSeek +seek ps = do + format <- getFormat + withFilesInGit (whenAnnexed $ start format) ps start :: Maybe Utility.Format.Format -> FilePath -> (Key, Backend) -> CommandStart start format file (key, _) = do diff --git a/Command/Fix.hs b/Command/Fix.hs index a63a10f8f9..9339585d10 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -24,8 +24,8 @@ def :: [Command] def = [notDirect $ noCommit $ command "fix" paramPaths seek SectionMaintenance "fix up symlinks to point to annexed content"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start {- Fixes the symlink to an annexed file. -} start :: FilePath -> (Key, Backend) -> CommandStart diff --git a/Command/Forget.hs b/Command/Forget.hs index 74bd68ad1d..0f247f9681 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -26,9 +26,10 @@ forgetOptions = [dropDeadOption] dropDeadOption :: Option dropDeadOption = Option.flag [] "drop-dead" "drop references to dead repositories" -seek :: [CommandSeek] -seek = [withFlag dropDeadOption $ \dropdead -> - withNothing $ start dropdead] +seek :: CommandSeek +seek ps = do + dropdead <- getOptionFlag dropDeadOption + withNothing (start dropdead) ps start :: Bool -> CommandStart start dropdead = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs index c3d2daafe2..784731ad78 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -20,8 +20,8 @@ def = [notDirect $ notBareRepo $ command "fromkey" (paramPair paramKey paramPath) seek SectionPlumbing "adds a file using a specific key"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (keyname:file:[]) = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 2ab47b5627..8b320f2096 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -70,16 +70,17 @@ fsckOptions = , incrementalScheduleOption ] ++ keyOptions -seek :: [CommandSeek] -seek = - [ withField fromOption Remote.byNameWithUUID $ \from -> - withIncremental $ \i -> - withKeyOptions (startKey i) $ - withFilesInGit $ whenAnnexed $ start from i - ] +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + i <- getIncremental + withKeyOptions + (startKey i) + (withFilesInGit $ whenAnnexed $ start from i) + ps -withIncremental :: (Incremental -> CommandSeek) -> CommandSeek -withIncremental = withValue $ do +getIncremental :: Annex Incremental +getIncremental = do i <- maybe (return False) (checkschedule . parseDuration) =<< Annex.getField (Option.name incrementalScheduleOption) starti <- Annex.getFlag (Option.name startIncrementalOption) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index 34e74b4334..2ed0fed62a 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -25,8 +25,8 @@ def :: [Command] def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionPlumbing "generates fuzz test files"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index bdd770f159..2448467fdd 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -18,8 +18,8 @@ def = [dontCheck repoExists $ noCommit $ command "gcryptsetup" paramValue seek SectionPlumbing "sets up gcrypt repository"] -seek :: [CommandSeek] -seek = [withStrings start] +seek :: CommandSeek +seek = withStrings start start :: String -> CommandStart start gcryptid = next $ next $ do diff --git a/Command/Get.hs b/Command/Get.hs index 52fbd25f9d..c83692a8dd 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -24,12 +24,13 @@ def = [withOptions getOptions $ command "get" paramPaths seek getOptions :: [Option] getOptions = fromOption : keyOptions -seek :: [CommandSeek] -seek = - [ withField fromOption Remote.byNameWithUUID $ \from -> - withKeyOptions (startKeys from) $ - withFilesInGit $ whenAnnexed $ start from - ] +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKeys from) + (withFilesInGit $ whenAnnexed $ start from) + ps start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start from file (key, _) = start' expensivecheck from key (Just file) diff --git a/Command/Group.hs b/Command/Group.hs index 4c0bf4899a..b0dbc14653 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "group" (paramPair paramRemote paramDesc) seek SectionSetup "add a repository to a group"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do diff --git a/Command/Help.hs b/Command/Help.hs index 71e767663b..5292c3ca3a 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -26,8 +26,8 @@ def :: [Command] def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "help" paramNothing seek SectionQuery "display help"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start params = do diff --git a/Command/Import.hs b/Command/Import.hs index dcf2b0fa0b..dda2f3bc49 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -61,8 +61,10 @@ getDuplicateMode = gen gen False False False True = SkipDuplicates gen _ _ _ _ = error "bad combination of --duplicate, --deduplicate, --clean-duplicates, --skip-duplicates" -seek :: [CommandSeek] -seek = [withValue getDuplicateMode $ \mode -> withPathContents $ start mode] +seek :: CommandSeek +seek ps = do + mode <- getDuplicateMode + withPathContents (start mode) ps start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart start mode (srcfile, destfile) = diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index d16362205a..2675b7a546 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -41,11 +41,12 @@ def = [notBareRepo $ withOptions [templateOption, relaxedOption] $ 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] +seek :: CommandSeek +seek ps = do + tmpl <- getOptionField templateOption return + relaxed <- getOptionFlag relaxedOption + cache <- getCache tmpl + withStrings (start relaxed cache) ps start :: Bool -> Cache -> URLString -> CommandStart start relaxed cache url = do diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index 4410d722d0..11cbdb73dd 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -15,8 +15,8 @@ def :: [Command] def = [noCommit $ command "inannex" (paramRepeating paramKey) seek SectionPlumbing "checks if keys are present in the annex"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = inAnnexSafe key >>= dispatch diff --git a/Command/Indirect.hs b/Command/Indirect.hs index a8669fe505..194be68213 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -31,8 +31,8 @@ def = [notBareRepo $ noDaemonRunning $ command "indirect" paramNothing seek SectionSetup "switch repository to indirect mode"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = ifM isDirect diff --git a/Command/Info.hs b/Command/Info.hs index b623d58e72..fde51968d2 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -75,8 +75,8 @@ def = [noCommit $ withOptions [jsonOption] $ command "info" paramPaths seek SectionQuery "shows general information about the annex"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start [] = do diff --git a/Command/Init.hs b/Command/Init.hs index 3db9a6be3e..a076cb486e 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -15,8 +15,8 @@ def :: [Command] def = [dontCheck repoExists $ command "init" paramDesc seek SectionSetup "initialize git-annex"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 5a240f8003..79fbcf39c5 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -24,8 +24,8 @@ def = [command "initremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) seek SectionSetup "creates a special (non-git) remote"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start [] = error "Specify a name for the remote." diff --git a/Command/List.hs b/Command/List.hs index 663da45003..7639081165 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -31,11 +31,11 @@ def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek allrepos :: Option allrepos = Option.flag [] "allrepos" "show all repositories, not only remotes" -seek :: [CommandSeek] -seek = - [ withValue getList $ withWords . startHeader - , withValue getList $ withFilesInGit . whenAnnexed . start - ] +seek :: CommandSeek +seek ps = do + list <- getList + printHeader list + withFilesInGit (whenAnnexed $ start list) ps getList :: Annex [(UUID, RemoteName, TrustLevel)] getList = ifM (Annex.getFlag $ Option.name allrepos) @@ -58,10 +58,8 @@ getList = ifM (Annex.getFlag $ Option.name allrepos) return $ sortBy (comparing snd3) $ filter (\t -> thd3 t /= DeadTrusted) rs3 -startHeader :: [(UUID, RemoteName, TrustLevel)] -> [String] -> CommandStart -startHeader l _ = do - liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l - stop +printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () +printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> (Key, Backend) -> CommandStart start l file (key, _) = do diff --git a/Command/Lock.hs b/Command/Lock.hs index bceba4a919..e6733dcb1b 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -16,8 +16,10 @@ def :: [Command] def = [notDirect $ command "lock" paramPaths seek SectionCommon "undo unlock command"] -seek :: [CommandSeek] -seek = [withFilesUnlocked start, withFilesUnlockedToBeCommitted start] +seek :: CommandSeek +seek ps = do + withFilesUnlocked start ps + withFilesUnlockedToBeCommitted start ps start :: FilePath -> CommandStart start file = do diff --git a/Command/Log.hs b/Command/Log.hs index f3a5becb8a..b7ad664cf9 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -53,12 +53,13 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++ 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] +seek :: CommandSeek +seek ps = do + m <- Remote.uuidDescriptions + zone <- liftIO getCurrentTimeZone + os <- concat <$> mapM getoption passthruOptions + gource <- getOptionFlag gourceOption + withFilesInGit (whenAnnexed $ start m zone os gource) ps where getoption o = maybe [] (use o) <$> Annex.getField (Option.name o) diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index aa83266cb1..814c5d2d77 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -17,8 +17,8 @@ def = [notBareRepo $ noCommit $ noMessages $ command "lookupkey" (paramRepeating paramFile) seek SectionPlumbing "looks up key used for file"] -seek :: [CommandSeek] -seek = [withStrings start] +seek :: CommandSeek +seek = withStrings start start :: String -> CommandStart start file = do diff --git a/Command/Map.hs b/Command/Map.hs index 575e321228..9b80d2035d 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -31,8 +31,8 @@ def = [dontCheck repoExists $ command "map" paramNothing seek SectionQuery "generate map of repositories"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Merge.hs b/Command/Merge.hs index 31db7a99f9..51a8b9c527 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -17,11 +17,10 @@ def :: [Command] def = [command "merge" paramNothing seek SectionMaintenance "automatically merge changes from remotes"] -seek :: [CommandSeek] -seek = - [ withNothing mergeBranch - , withNothing mergeSynced - ] +seek :: CommandSeek +seek ps = do + withNothing mergeBranch ps + withNothing mergeSynced ps mergeBranch :: CommandStart mergeBranch = do diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 0fdf0e8176..c14c07bddb 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -22,8 +22,8 @@ def = [notDirect $ command "migrate" paramPaths seek SectionUtility "switch data to different backend"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start start :: FilePath -> (Key, Backend) -> CommandStart start file (key, oldbackend) = do diff --git a/Command/Mirror.hs b/Command/Mirror.hs index fb829bcb02..cf4663cb59 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -22,13 +22,14 @@ def = [withOptions (fromToOptions ++ keyOptions) $ 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 -> - withKeyOptions (startKey Nothing to from Nothing) $ - withFilesInGit $ whenAnnexed $ start to from - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKey Nothing to from Nothing) + (withFilesInGit $ whenAnnexed $ start to from) + ps start :: Maybe Remote -> Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart start to from file (key, _backend) = do diff --git a/Command/Move.hs b/Command/Move.hs index 7d11b5abd5..b79e4c9299 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -26,13 +26,14 @@ def = [withOptions moveOptions $ command "move" paramPaths seek 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 - ] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + withKeyOptions + (startKey to from True) + (withFilesInGit $ whenAnnexed $ start to from True) + ps start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart start to from move file (key, _) = start' to from move (Just file) key diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index eed2f491c6..6644f6ffa4 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -9,6 +9,7 @@ module Command.PreCommit where import Common.Annex import Command +import Config import qualified Command.Add import qualified Command.Fix import Annex.Direct @@ -17,19 +18,20 @@ 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 +seek :: CommandSeek +seek ps = ifM isDirect -- update direct mode mappings for committed files - , whenDirect $ withWords startDirect - ] + ( withWords startDirect ps + , do + -- fix symlinks to files being committed + withFilesToBeCommitted (whenAnnexed Command.Fix.start) ps + -- inject unlocked files into the annex + withFilesUnlockedToBeCommitted startIndirect ps + ) startIndirect :: FilePath -> CommandStart startIndirect file = next $ do - unlessM (doCommand $ Command.Add.start file) $ + unlessM (callCommand $ Command.Add.start file) $ error $ "failed to add " ++ file ++ "; canceling commit" next $ return True diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 7448ba97e6..805300f9f8 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -22,8 +22,8 @@ def = [notDirect $ command "rekey" (paramOptional $ paramRepeating $ paramPair paramPath paramKey) seek SectionPlumbing "change keys used for files"] -seek :: [CommandSeek] -seek = [withPairs start] +seek :: CommandSeek +seek = withPairs start start :: (FilePath, String) -> CommandStart start (file, keyname) = ifAnnexed file go stop diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 3b2a8c496a..6964ea5bdb 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -26,8 +26,8 @@ def :: [Command] def = [noCommit $ command "recvkey" paramKey seek SectionPlumbing "runs rsync in server mode to receive content"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = ifM (inAnnex key) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index c49af00601..1609c60974 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -17,8 +17,8 @@ def :: [Command] def = [command "reinject" (paramPair "SRC" "DEST") seek SectionUtility "sets content of annexed file"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start (src:dest:[]) diff --git a/Command/Repair.hs b/Command/Repair.hs index 0f02a3ab32..c873176851 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -20,8 +20,8 @@ def :: [Command] def = [noCommit $ dontCheck repoExists $ command "repair" paramNothing seek SectionMaintenance "recover broken git repository"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = next $ next $ runRepair =<< Annex.getState Annex.force diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index d3ded38a39..3f304b76ed 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -16,8 +16,8 @@ def = [notBareRepo $ command "rmurl" (paramPair paramFile paramUrl) seek SectionCommon "record file is not available at url"] -seek :: [CommandSeek] -seek = [withPairs start] +seek :: CommandSeek +seek = withPairs start start :: (FilePath, String) -> CommandStart start (file, url) = flip whenAnnexed file $ \_ (key, _) -> do diff --git a/Command/Schedule.hs b/Command/Schedule.hs index db654f2911..a088dbef8b 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -21,8 +21,8 @@ def :: [Command] def = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek SectionSetup "get or set scheduled jobs"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start = parse diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs index e205636726..26ce6961bb 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "semitrust" (paramRepeating paramRemote) seek SectionSetup "return repository to default trust level"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 24b1821c3f..488480e0ac 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -20,8 +20,8 @@ def :: [Command] def = [noCommit $ command "sendkey" paramKey seek SectionPlumbing "runs rsync in server mode to send content"] -seek :: [CommandSeek] -seek = [withKeys start] +seek :: CommandSeek +seek = withKeys start start :: Key -> CommandStart start key = do diff --git a/Command/Status.hs b/Command/Status.hs index 27127b3ecf..462d68e050 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -22,10 +22,8 @@ def = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ command "status" paramPaths seek SectionCommon "show the working tree status"] -seek :: [CommandSeek] -seek = - [ withWords start - ] +seek :: CommandSeek +seek = withWords start start :: [FilePath] -> CommandStart start [] = do diff --git a/Command/Sync.hs b/Command/Sync.hs index 1b50827007..25e54a56b9 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -47,7 +47,7 @@ import Control.Concurrent.MVar def :: [Command] def = [withOptions syncOptions $ command "sync" (paramOptional (paramRepeating paramRemote)) - [seek] SectionCommon "synchronize local repository with remotes"] + seek SectionCommon "synchronize local repository with remotes"] syncOptions :: [Option] syncOptions = [ contentOption ] @@ -55,7 +55,6 @@ syncOptions = [ contentOption ] contentOption :: Option contentOption = Option.flag [] "content" "also transfer file contents" --- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do prepMerge @@ -78,20 +77,16 @@ seek rs = do remotes <- syncRemotes rs let gitremotes = filter Remote.gitSyncableRemote remotes - synccontent <- ifM (Annex.getFlag $ Option.name contentOption) - ( withFilesInGit (whenAnnexed $ syncContent remotes) [] - , return [] - ) - - return $ concat - [ [ commit ] - , [ withbranch mergeLocal ] - , map (withbranch . pullRemote) gitremotes - , [ mergeAnnex ] - , synccontent - , [ withbranch pushLocal ] - , map (withbranch . pushRemote) gitremotes - ] + -- Syncing involves many actions, any of which can independently + -- fail, without preventing the others from running. + seekActions $ return [ commit ] + seekActions $ return [ withbranch mergeLocal ] + seekActions $ return $ map (withbranch . pullRemote) gitremotes + seekActions $ return [ mergeAnnex ] + whenM (Annex.getFlag $ Option.name contentOption) $ + withFilesInGit (whenAnnexed $ syncContent remotes) [] + seekActions $ return $ [ withbranch pushLocal ] + seekActions $ return $ map (withbranch . pushRemote) gitremotes {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the diff --git a/Command/Test.hs b/Command/Test.hs index be480eeb71..47d72ee445 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -16,8 +16,8 @@ def = [ noRepo startIO $ dontCheck repoExists $ command "test" paramNothing seek SectionPlumbing "run built-in test suite"] -seek :: [CommandSeek] -seek = [withWords start] +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 diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 93f6c7077a..7965031330 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -19,8 +19,8 @@ def :: [Command] def = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing "updates sender on number of bytes of content received"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start {- Security: - diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 41a207080a..f3856eb2e4 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -28,11 +28,12 @@ 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] +seek :: CommandSeek +seek ps = do + to <- getOptionField toOption Remote.byNameWithUUID + from <- getOptionField fromOption Remote.byNameWithUUID + file <- getOptionField fileOption return + withKeys (start to from file) ps start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart start to from file key = diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 6d8db4ef2a..9c05702be6 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -25,8 +25,8 @@ def :: [Command] def = [command "transferkeys" paramNothing seek SectionPlumbing "transfers keys"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = withHandles $ \(readh, writeh) -> do diff --git a/Command/Trust.hs b/Command/Trust.hs index 26993ef771..3898af347a 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "trust" (paramRepeating paramRemote) seek SectionSetup "trust a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 5e3c4279aa..1f29784308 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -23,8 +23,8 @@ def :: [Command] def = [command "unannex" paramPaths seek SectionUtility "undo accidential add command"] -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start start :: FilePath -> (Key, Backend) -> CommandStart start file (key, _) = stopUnless (inAnnex key) $ do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index a6557f21d3..a88e3f7c8e 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -19,8 +19,8 @@ def :: [Command] def = [command "ungroup" (paramPair paramRemote paramDesc) seek SectionSetup "remove a repository from a group"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start (name:g:[]) = do diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 3fbe6758a4..f608d03fec 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -34,12 +34,11 @@ check = do revhead = inRepo $ Git.Command.pipeReadStrict [Params "rev-parse --abbrev-ref HEAD"] -seek :: [CommandSeek] -seek = - [ withFilesNotInGit $ whenAnnexed startCheckIncomplete - , withFilesInGit $ whenAnnexed Command.Unannex.start - , withNothing start - ] +seek :: CommandSeek +seek ps = do + withFilesNotInGit (whenAnnexed startCheckIncomplete) ps + withFilesInGit (whenAnnexed Command.Unannex.start) ps + finish {- git annex symlinks that are not checked into git could be left by an - interrupted add. -} @@ -50,8 +49,8 @@ startCheckIncomplete file _ = error $ unlines , "Not continuing with uninit; either delete or git annex add the file and retry." ] -start :: CommandStart -start = next $ next $ do +finish :: Annex () +finish = do annexdir <- fromRepo gitAnnexDir annexobjectdir <- fromRepo gitAnnexObjectDir leftovers <- removeUnannexed =<< getKeysPresent diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 1eba26ff72..9f2c257fbc 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -20,8 +20,8 @@ def = where c n = notDirect . command n paramPaths seek SectionCommon -seek :: [CommandSeek] -seek = [withFilesInGit $ whenAnnexed start] +seek :: CommandSeek +seek = withFilesInGit $ whenAnnexed start {- The unlock subcommand replaces the symlink with a copy of the file's - content. -} diff --git a/Command/Untrust.hs b/Command/Untrust.hs index f18637838e..cde1eee930 100644 --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -16,8 +16,8 @@ def :: [Command] def = [command "untrust" (paramRepeating paramRemote) seek SectionSetup "do not trust a repository"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start ws = do diff --git a/Command/Unused.hs b/Command/Unused.hs index f99528cfa7..19dc820071 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -45,8 +45,8 @@ def = [withOptions [fromOption] $ command "unused" paramNothing seek fromOption :: Option fromOption = Option.field ['f'] "from" paramRemote "remote to check for unused content" -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start {- Finds unused content in the annex. -} start :: CommandStart @@ -326,14 +326,14 @@ data UnusedMaps = UnusedMaps , 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) $ + let unusedmaps = UnusedMaps unused unusedbad unusedtmp + seekActions $ return $ map (a unusedmaps) $ concatMap (unusedSpec m) params unusedSpec :: UnusedMap -> String -> [Int] @@ -349,8 +349,8 @@ unusedSpec m spec _ -> 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. -} +{- Seek action for unused content. Finds the number in the maps, and + - calls one of 3 actions, depending on the type of unused file. -} startUnused :: String -> (Key -> CommandPerform) -> (Key -> CommandPerform) diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index de34278dde..80876290a4 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -16,8 +16,8 @@ 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] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Version.hs b/Command/Version.hs index 0326b9edeb..526b752f04 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -21,8 +21,8 @@ def :: [Command] def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "version" paramNothing seek SectionQuery "show version info"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 22c641408a..7608959c24 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -30,8 +30,8 @@ def :: [Command] def = [command "vicfg" paramNothing seek SectionSetup "edit git-annex's configuration"] -seek :: [CommandSeek] -seek = [withNothing start] +seek :: CommandSeek +seek = withNothing start start :: CommandStart start = do diff --git a/Command/Wanted.hs b/Command/Wanted.hs index 9ea0c211fd..bae450d265 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -20,8 +20,8 @@ def :: [Command] def = [command "wanted" (paramPair paramRemote (paramOptional paramExpression)) seek SectionSetup "get or set preferred content expression"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start = parse diff --git a/Command/Watch.hs b/Command/Watch.hs index a33fc633c0..bcfdf14bf4 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -17,10 +17,11 @@ 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] +seek :: CommandSeek +seek ps = do + stopdaemon <- getOptionFlag stopOption + foreground <- getOptionFlag foregroundOption + withNothing (start False foreground stopdaemon Nothing) ps foregroundOption :: Option foregroundOption = Option.flag [] "foreground" "do not daemonize" diff --git a/Command/WebApp.hs b/Command/WebApp.hs index a009be15de..a05984c4e2 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -48,9 +48,10 @@ listenOption :: Option listenOption = Option.field [] "listen" paramAddress "accept connections to this address" -seek :: [CommandSeek] -seek = [withField listenOption return $ \listenhost -> - withNothing $ start listenhost] +seek :: CommandSeek +seek ps = do + listenhost <- getOptionField listenOption return + withNothing (start listenhost) ps start :: Maybe HostName -> CommandStart start = start' True @@ -107,7 +108,7 @@ startNoRepo _ = do (d:_) -> do setCurrentDirectory d state <- Annex.new =<< Git.CurrentRepo.get - void $ Annex.eval state $ doCommand $ + void $ Annex.eval state $ callCommand $ start' False listenhost {- Run the webapp without a repository, which prompts the user, makes one, diff --git a/Command/Whereis.hs b/Command/Whereis.hs index fcbbbf0d54..4030cf2f8e 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -20,9 +20,10 @@ def = [noCommit $ withOptions [jsonOption] $ command "whereis" paramPaths seek SectionQuery "lists repositories that have file content"] -seek :: [CommandSeek] -seek = [withValue (remoteMap id) $ \m -> - withFilesInGit $ whenAnnexed $ start m] +seek :: CommandSeek +seek ps = do + m <- remoteMap id + withFilesInGit (whenAnnexed $ start m) ps start :: M.Map UUID Remote -> FilePath -> (Key, Backend) -> CommandStart start remotemap file (key, _) = do diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 796e8b4edd..47c2d7ff24 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -16,8 +16,8 @@ def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "xmppgit" paramNothing seek SectionPlumbing "git to XMPP relay"] -seek :: [CommandSeek] -seek = [withWords start] +seek :: CommandSeek +seek = withWords start start :: [String] -> CommandStart start _ = do diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index b5f6804e77..7c3893be34 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -104,7 +104,7 @@ builtin cmd dir params = do Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath where addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k - newcmd opts c = c { cmdseek = map (addrsyncopts opts) (cmdseek c) } + newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) } external :: [String] -> IO () external params = do diff --git a/RunCommand.hs b/RunCommand.hs new file mode 100644 index 0000000000..32a9c7d486 --- /dev/null +++ b/RunCommand.hs @@ -0,0 +1,64 @@ +{- git-annex running commands + - + - Copyright 2010-2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module RunCommand where + +import Common.Annex +import qualified Annex +import Types.Command +import qualified Annex.Queue +import Annex.Exception + +{- Runs a command, starting with the check stage, and then + - the seek stage. Finishes by printing the number of commandActions that + - failed. -} +performCommand :: Command -> CmdParams -> Annex () +performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = do + mapM_ runCheck c + Annex.changeState $ \s -> s { Annex.errcounter = 0 } + seek params + showerrcount =<< Annex.getState Annex.errcounter + where + showerrcount 0 = noop + showerrcount cnt = error $ name ++ ": " ++ show cnt ++ " failed" + +{- Runs one of the actions needed to perform a command. + - Individual actions can fail without stopping the whole command, + - including by throwing IO errors (but other errors terminate the whole + - command). + - + - This should only be run in the seek stage. -} +commandAction :: CommandStart -> Annex () +commandAction a = handle =<< tryAnnexIO go + where + go = do + Annex.Queue.flushWhenFull + callCommand a + handle (Right True) = noop + handle (Right False) = incerr + handle (Left err) = do + showErr err + showEndFail + incerr + incerr = Annex.changeState $ \s -> + let ! c = Annex.errcounter s + 1 + ! s' = s { Annex.errcounter = c } + in s' + +{- Runs a single command action through the start, perform and cleanup stages -} +callCommand :: CommandStart -> CommandCleanup +callCommand = start + where + start = stage $ maybe skip perform + perform = stage $ maybe failure cleanup + cleanup = stage $ status + stage = (=<<) + skip = return True + failure = showEndFail >> return False + status r = showEndResult r >> return r diff --git a/Seek.hs b/Seek.hs index 3c84814f52..57bedfc848 100644 --- a/Seek.hs +++ b/Seek.hs @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -23,23 +23,14 @@ import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Limit import qualified Option -import Config import Logs.Location import Logs.Unused import Annex.CatFile - -seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] -seekHelper a params = do - ll <- inRepo $ \g -> - runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params - {- Show warnings only for files/directories that do not exist. -} - forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> - unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ - fileNotFound p - return $ concat ll +import RunCommand withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek -withFilesInGit a params = prepFiltered a $ seekHelper LsFiles.inRepo params +withFilesInGit a params = seekActions $ prepFiltered a $ + seekHelper LsFiles.inRepo params withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek withFilesNotInGit a params = do @@ -47,7 +38,8 @@ withFilesNotInGit a params = do files <- filter (not . dotfile) <$> seekunless (null ps && not (null params)) ps dotfiles <- seekunless (null dotps) dotps - prepFiltered a $ return $ concat $ segmentPaths params (files++dotfiles) + seekActions $ prepFiltered a $ + return $ concat $ segmentPaths params (files++dotfiles) where (dotps, ps) = partition dotfile params seekunless True _ = return [] @@ -57,7 +49,8 @@ withFilesNotInGit a params = do liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek -withPathContents a params = map a . concat <$> liftIO (mapM get params) +withPathContents a params = seekActions $ + map a . concat <$> liftIO (mapM get params) where get p = ifM (isDirectory <$> getFileStatus p) ( map (\f -> (f, makeRelative (parentDir p) f)) @@ -66,20 +59,20 @@ withPathContents a params = map a . concat <$> liftIO (mapM get params) ) withWords :: ([String] -> CommandStart) -> CommandSeek -withWords a params = return [a params] +withWords a params = seekActions $ return [a params] withStrings :: (String -> CommandStart) -> CommandSeek -withStrings a params = return $ map a params +withStrings a params = seekActions $ return $ map a params withPairs :: ((String, String) -> CommandStart) -> CommandSeek -withPairs a params = return $ map a $ pairs [] params +withPairs a params = seekActions $ return $ map a $ pairs [] params where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = error "expected pairs" withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek -withFilesToBeCommitted a params = prepFiltered a $ +withFilesToBeCommitted a params = seekActions $ prepFiltered a $ seekHelper LsFiles.stagedNotDeleted params withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek @@ -94,7 +87,8 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged - not some other sort of symlink. -} withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek -withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles +withFilesUnlocked' typechanged a params = seekActions $ + prepFiltered a unlockedfiles where check f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) @@ -102,32 +96,25 @@ withFilesUnlocked' typechanged a params = prepFiltered a unlockedfiles {- Finds files that may be modified. -} withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek -withFilesMaybeModified a params = +withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params withKeys :: (Key -> CommandStart) -> CommandSeek -withKeys a params = return $ map (a . parse) params +withKeys a params = seekActions $ return $ map (a . parse) params where parse p = fromMaybe (error "bad key") $ file2key p -withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek -withValue v a params = do - r <- v - a r params - -{- Modifies a seek action using the value of a field option, which is fed into - - a conversion function, and then is passed into the seek action. - - This ensures that the conversion function only runs once. +{- Gets the value of a field options, which is fed into + - a conversion function. -} -withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek -withField option converter = withValue $ - converter <=< Annex.getField $ Option.name option +getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a +getOptionField option converter = converter <=< Annex.getField $ Option.name option -withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek -withFlag option = withValue $ Annex.getFlag (Option.name option) +getOptionFlag :: Option -> Annex Bool +getOptionFlag option = Annex.getFlag (Option.name option) withNothing :: CommandStart -> CommandSeek -withNothing a [] = return [a] +withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." {- If --all is specified, or in a bare repo, runs an action on all @@ -159,7 +146,7 @@ withKeyOptions keyop fallbackop params = do unless (null params) $ error "Cannot mix --all or --unused with file names." matcher <- Limit.getMatcher - map (process matcher) <$> a + seekActions $ map (process matcher) <$> a process matcher k = ifM (matcher $ MatchingKey k) ( keyop k , return Nothing) @@ -171,11 +158,20 @@ prepFiltered a fs = do process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f) ( a f , return Nothing ) +seekActions :: Annex [CommandStart] -> Annex () +seekActions gen = do + as <- gen + mapM_ commandAction as + +seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] +seekHelper a params = do + ll <- inRepo $ \g -> + runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params + {- Show warnings only for files/directories that do not exist. -} + forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> + unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ + fileNotFound p + return $ concat ll + notSymlink :: FilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f - -whenNotDirect :: CommandSeek -> CommandSeek -whenNotDirect a params = ifM isDirect ( return [] , a params ) - -whenDirect :: CommandSeek -> CommandSeek -whenDirect a params = ifM isDirect ( a params, return [] ) diff --git a/Types/Command.hs b/Types/Command.hs index d012c6e257..ecde75cae5 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -18,9 +18,9 @@ import Types data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () } {- b. The seek stage takes the parameters passed to the command, - looks through the repo to find the ones that are relevant - - to that command (ie, new files to add), and generates - - a list of start stage actions. -} -type CommandSeek = [String] -> Annex [CommandStart] + - to that command (ie, new files to add), and runs commandAction + - to handle all necessary actions. -} +type CommandSeek = [String] -> Annex () {- c. The start stage is run before anything is printed about the - command, is passed some input, and can early abort it - if the input does not make sense. It should run quickly and @@ -42,7 +42,7 @@ data Command = Command , cmdnomessages :: Bool -- don't output normal messages , cmdname :: String , cmdparamdesc :: String -- description of params for usage - , cmdseek :: [CommandSeek] -- seek stage + , cmdseek :: CommandSeek , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage } From 1ba8ea0c8a2645a6213ddebdb8f4bc730239747c Mon Sep 17 00:00:00 2001 From: "https://www.google.com/accounts/o8/id?id=AItOawm_YXzEdPHzbSGVwtmTR7g1BqDtTnIBB5s" Date: Mon, 20 Jan 2014 16:22:21 +0000 Subject: [PATCH 03/16] Added a comment: Chunk it --- ...omment_12_e3029c65d34f78272bc11961ebfd8237._comment | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 doc/design/external_special_remote_protocol/comment_12_e3029c65d34f78272bc11961ebfd8237._comment diff --git a/doc/design/external_special_remote_protocol/comment_12_e3029c65d34f78272bc11961ebfd8237._comment b/doc/design/external_special_remote_protocol/comment_12_e3029c65d34f78272bc11961ebfd8237._comment new file mode 100644 index 0000000000..e8d0dcfe8e --- /dev/null +++ b/doc/design/external_special_remote_protocol/comment_12_e3029c65d34f78272bc11961ebfd8237._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawm_YXzEdPHzbSGVwtmTR7g1BqDtTnIBB5s" + nickname="Matthias" + subject="Chunk it" + date="2014-01-20T16:22:09Z" + content=""" +> TODO: stream the file up/down the pipe, rather than using a temp file + +You might want to use chunked transfer, i.e. a series of \"EXPECT 65536\" followed by that many bytes of binary data and an EOF marker (EXPECT-END or EXPECT 0), instead of escaping three characters (newline, NUL, and the escape prefix) and the additional unnecessary tedious per-character processing that would require. +"""]] From 4a0fbbd472060498512a667b03f5fb467d6856bf Mon Sep 17 00:00:00 2001 From: "http://joeyh.name/" Date: Mon, 20 Jan 2014 16:28:50 +0000 Subject: [PATCH 04/16] Added a comment --- .../comment_10_8d90e23514d9f14283857c57017a5fcf._comment | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 doc/bugs/Share_with_friends_crash_in_osx/comment_10_8d90e23514d9f14283857c57017a5fcf._comment diff --git a/doc/bugs/Share_with_friends_crash_in_osx/comment_10_8d90e23514d9f14283857c57017a5fcf._comment b/doc/bugs/Share_with_friends_crash_in_osx/comment_10_8d90e23514d9f14283857c57017a5fcf._comment new file mode 100644 index 0000000000..ef7579c46b --- /dev/null +++ b/doc/bugs/Share_with_friends_crash_in_osx/comment_10_8d90e23514d9f14283857c57017a5fcf._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.68" + subject="comment 10" + date="2014-01-20T16:28:43Z" + content=""" +I have updated the autobuild again, now nettle is built with more optimisations disabled. I hope this fixes it because I'm running out of things to try. +"""]] From dde13f775a50fa09fdd9a11163ce59948864dddd Mon Sep 17 00:00:00 2001 From: "http://joeyh.name/" Date: Mon, 20 Jan 2014 16:33:28 +0000 Subject: [PATCH 05/16] Added a comment --- ...comment_3_0c9c9c0ed557af4845a67434c21bb4bc._comment | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 doc/forum/Can_not_drop_unused_file/comment_3_0c9c9c0ed557af4845a67434c21bb4bc._comment diff --git a/doc/forum/Can_not_drop_unused_file/comment_3_0c9c9c0ed557af4845a67434c21bb4bc._comment b/doc/forum/Can_not_drop_unused_file/comment_3_0c9c9c0ed557af4845a67434c21bb4bc._comment new file mode 100644 index 0000000000..8a1ecfdd24 --- /dev/null +++ b/doc/forum/Can_not_drop_unused_file/comment_3_0c9c9c0ed557af4845a67434c21bb4bc._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="http://joeyh.name/" + ip="209.250.56.68" + subject="comment 3" + date="2014-01-20T16:33:27Z" + content=""" +I see you're using encryption. That could have something to do with the problem. Which type of encryption was used for this special remote? encryption=shared or one of the other options? + +Look through the whole strace output for attempts to access the directory special remote and show those. Or put up the full strace somewhere. +"""]] From cfa6865056700b560736dda97ffb2c658bf3f35d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 12:36:19 -0400 Subject: [PATCH 06/16] wontfix --- ...__93__:_add_an_option_to_install__SSH_key_on_remote.mdwn | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/todo/wishlist__91__webapp__93__:_add_an_option_to_install__SSH_key_on_remote.mdwn b/doc/todo/wishlist__91__webapp__93__:_add_an_option_to_install__SSH_key_on_remote.mdwn index 297047e064..fe32f7dd77 100644 --- a/doc/todo/wishlist__91__webapp__93__:_add_an_option_to_install__SSH_key_on_remote.mdwn +++ b/doc/todo/wishlist__91__webapp__93__:_add_an_option_to_install__SSH_key_on_remote.mdwn @@ -1,3 +1,9 @@ When adding a Remote server through the webapp, it set-up a specific SSH key for later sync. However, when the remote has been set-up manually, then later gets the assistant thrown at it, there doesn't appear to be a way to create and deploy such a key. This option could be offered in, e.g., the settings of the repo in the webapp. + +> I feel this is out of scope for the assistant. If the user is able to +> manually add a git remote at the command line, then they should be able +> to configure ssh keys too. I don't want to complicate the assistant with +> a lot of code that tries to deal with half-configured things the user +> manually set up. [[wontfix|done]] --[[Joey]] From 73c420ffcf41dda4daaf6d05e5ec52b1b7444ebe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 13:31:03 -0400 Subject: [PATCH 07/16] much better command action handling for sync --content --- Annex/Drop.hs | 33 ++++++-------- Assistant/Drop.hs | 3 +- Assistant/Threads/TransferScanner.hs | 3 +- Command/Sync.hs | 68 ++++++++++++++-------------- RunCommand.hs | 22 +++++---- 5 files changed, 68 insertions(+), 61 deletions(-) diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 3e915c315d..6386f11bbf 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -18,6 +18,7 @@ import Annex.Wanted import Annex.Exception import Config import Annex.Content.Direct +import RunCommand import qualified Data.Set as S import System.Log.Logger (debugM) @@ -27,29 +28,24 @@ type Reason = String {- Drop a key from local and/or remote when allowed by the preferred content - and numcopies settings. - - - The Remote list can include other remotes that do not have the content. - - - - A remote can be specified that is known to have the key. This can be - - used an an optimisation when eg, a key has just been uploaded to a - - remote. - -} -handleDrops :: Reason -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex () -handleDrops _ _ _ _ Nothing _ = noop -handleDrops reason rs fromhere key f knownpresentremote = do - locs <- loggedLocations key - handleDropsFrom locs rs reason fromhere key f knownpresentremote - -{- The UUIDs are ones where the content is believed to be present. + - The UUIDs are ones where the content is believed to be present. - The Remote list can include other remotes that do not have the content; - only ones that match the UUIDs will be dropped from. - If allowed to drop fromhere, that drop will be tried first. - + - A remote can be specified that is known to have the key. This can be + - used an an optimisation when eg, a key has just been uploaded to a + - remote. + - - In direct mode, all associated files are checked, and only if all - of them are unwanted are they dropped. + - + - The runner is used to run commands, and so can be either callCommand + - or commandAction. -} -handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex () -handleDropsFrom _ _ _ _ _ Nothing _ = noop -handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do +handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex () +handleDropsFrom _ _ _ _ _ Nothing _ _ = noop +handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runner = do fs <- ifM isDirect ( do l <- associatedFilesRelative key @@ -92,7 +88,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do checkdrop fs n@(have, numcopies, _untrusted) u a = ifM (allM (wantDrop True u . Just) fs) - ( ifM (safely $ callCommand $ a (Just numcopies)) + ( ifM (safely $ runner $ a (Just numcopies)) ( do liftIO $ debugM "drop" $ unwords [ "dropped" @@ -113,6 +109,7 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> Command.Drop.startRemote (Just afile) numcopies key r + slocs = S.fromList locs + safely a = either (const False) id <$> tryAnnex a - slocs = S.fromList locs diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 03ab5ab2ca..3020b0f4fe 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -14,6 +14,7 @@ import Assistant.Common import Assistant.DaemonStatus import Annex.Drop (handleDropsFrom, Reason) import Logs.Location +import RunCommand {- Drop from local and/or remote when allowed by the preferred content and - numcopies settings. -} @@ -22,4 +23,4 @@ handleDrops _ _ _ Nothing _ = noop handleDrops reason fromhere key f knownpresentremote = do syncrs <- syncDataRemotes <$> getDaemonStatus locs <- liftAnnex $ loggedLocations key - liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote + liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommand diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index b001957891..60f6dc28b5 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -29,6 +29,7 @@ import qualified Git.LsFiles as LsFiles import qualified Backend import Annex.Content import Annex.Wanted +import RunCommand import qualified Data.Set as S @@ -158,7 +159,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do present <- liftAnnex $ inAnnex key liftAnnex $ handleDropsFrom locs syncrs "expensive scan found too many copies of object" - present key (Just f) Nothing + present key (Just f) Nothing callCommand liftAnnex $ do let slocs = S.fromList locs let use a = return $ mapMaybe (a key slocs) syncrs diff --git a/Command/Sync.hs b/Command/Sync.hs index 25e54a56b9..9db3c7ad7f 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -79,14 +79,18 @@ seek rs = do -- Syncing involves many actions, any of which can independently -- fail, without preventing the others from running. - seekActions $ return [ commit ] - seekActions $ return [ withbranch mergeLocal ] - seekActions $ return $ map (withbranch . pullRemote) gitremotes - seekActions $ return [ mergeAnnex ] + seekActions $ return $ concat + [ [ commit ] + , [ withbranch mergeLocal ] + , map (withbranch . pullRemote) gitremotes + , [ mergeAnnex ] + ] whenM (Annex.getFlag $ Option.name contentOption) $ - withFilesInGit (whenAnnexed $ syncContent remotes) [] - seekActions $ return $ [ withbranch pushLocal ] - seekActions $ return $ map (withbranch . pushRemote) gitremotes + seekSyncContent remotes + seekActions $ return $ concat + [ [ withbranch pushLocal ] + , map (withbranch . pushRemote) gitremotes + ] {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the @@ -494,29 +498,24 @@ newer remote b = do - Drop it from each remote that has it, where it's not preferred content - (honoring numcopies). -} -syncContent :: [Remote] -> FilePath -> (Key, Backend) -> CommandStart -syncContent rs f (k, _) = do +seekSyncContent :: [Remote] -> Annex () +seekSyncContent rs = mapM_ go =<< seekHelper LsFiles.inRepo [] + where + go f = ifAnnexed f (syncFile rs f) noop + +syncFile :: [Remote] -> FilePath -> (Key, Backend) -> Annex () +syncFile rs f (k, _) = do locs <- loggedLocations k let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs - - getresults <- sequence =<< handleget have - (putresults, putrs) <- unzip <$> (sequence =<< handleput lack) - let locs' = catMaybes putrs ++ locs - handleDropsFrom locs' rs "unwanted" True k (Just f) Nothing + sequence_ =<< handleget have + putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack) - let results = getresults ++ putresults - if null results - then stop - else do - showStart "sync" f - next $ next $ return $ all id results + -- Using callCommand rather than commandAction for drops, + -- because a failure to drop does not mean the sync failed. + handleDropsFrom (putrs ++ locs) rs "unwanted" True k (Just f) + Nothing callCommand where - run a = do - r <- a - showEndResult r - return r - wantget have = allM id [ pure (not $ null have) , not <$> inAnnex k @@ -526,9 +525,9 @@ syncContent rs f (k, _) = do ( return [ get have ] , return [] ) - get have = do + get have = commandAction $ do showStart "get" f - run $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have + next $ next $ getViaTmp k $ \dest -> getKeyFile' k (Just f) dest have wantput r | Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False @@ -538,10 +537,13 @@ syncContent rs f (k, _) = do , return [] ) put dest = do - showStart "copy" f - showAction $ "to " ++ Remote.name dest - ok <- run $ upload (Remote.uuid dest) k (Just f) noRetry $ - Remote.storeKey dest k (Just f) - when ok $ - Remote.logStatus dest k InfoPresent + ok <- commandAction $ do + showStart "copy" f + showAction $ "to " ++ Remote.name dest + next $ next $ do + ok <- upload (Remote.uuid dest) k (Just f) noRetry $ + Remote.storeKey dest k (Just f) + when ok $ + Remote.logStatus dest k InfoPresent + return ok return (ok, if ok then Just (Remote.uuid dest) else Nothing) diff --git a/RunCommand.hs b/RunCommand.hs index 32a9c7d486..937686d975 100644 --- a/RunCommand.hs +++ b/RunCommand.hs @@ -15,6 +15,8 @@ import Types.Command import qualified Annex.Queue import Annex.Exception +type CommandActionRunner = CommandStart -> CommandCleanup + {- Runs a command, starting with the check stage, and then - the seek stage. Finishes by printing the number of commandActions that - failed. -} @@ -34,25 +36,29 @@ performCommand Command { cmdseek = seek, cmdcheck = c, cmdname = name } params = - command). - - This should only be run in the seek stage. -} -commandAction :: CommandStart -> Annex () +commandAction :: CommandActionRunner commandAction a = handle =<< tryAnnexIO go where go = do Annex.Queue.flushWhenFull callCommand a - handle (Right True) = noop + handle (Right True) = return True handle (Right False) = incerr handle (Left err) = do showErr err showEndFail incerr - incerr = Annex.changeState $ \s -> - let ! c = Annex.errcounter s + 1 - ! s' = s { Annex.errcounter = c } - in s' + incerr = do + Annex.changeState $ \s -> + let ! c = Annex.errcounter s + 1 + ! s' = s { Annex.errcounter = c } + in s' + return False -{- Runs a single command action through the start, perform and cleanup stages -} -callCommand :: CommandStart -> CommandCleanup +{- Runs a single command action through the start, perform and cleanup + - stages, without catching errors. Useful if one command wants to run + - part of another command. -} +callCommand :: CommandActionRunner callCommand = start where start = stage $ maybe skip perform From 5130bfdff39e52ea6a6d8bfafdb3488dfd49bec9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 13:37:13 -0400 Subject: [PATCH 08/16] export cleanup --- Command.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Command.hs b/Command.hs index aeffbbeb8e..555414458e 100644 --- a/Command.hs +++ b/Command.hs @@ -16,7 +16,6 @@ module Command ( next, stop, stopUnless, - runCommand, whenAnnexed, ifAnnexed, isBareRepo, From e7f8c1911a2edb4df9ad30a68fc2980697599e3f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 14:28:33 -0400 Subject: [PATCH 09/16] design for preferred content numcopies check --- ...fy__95__num__95__copies__34___command.mdwn | 12 ++-- .../preferred_content_numcopies_check.mdwn | 61 +++++++++++++++++++ 2 files changed, 66 insertions(+), 7 deletions(-) create mode 100644 doc/todo/preferred_content_numcopies_check.mdwn diff --git a/doc/todo/Provide_a___34__git_annex_satisfy__95__num__95__copies__34___command.mdwn b/doc/todo/Provide_a___34__git_annex_satisfy__95__num__95__copies__34___command.mdwn index 877e9fdbfb..cbd01181fa 100644 --- a/doc/todo/Provide_a___34__git_annex_satisfy__95__num__95__copies__34___command.mdwn +++ b/doc/todo/Provide_a___34__git_annex_satisfy__95__num__95__copies__34___command.mdwn @@ -7,12 +7,10 @@ for i in `git remote`; do git copy -to $i --auto; done The use case is this: I have a very large repo (300.000 files) in three places. Now I want the fastest possible way to ensure, that every file exists in annex.numcopies. This should scan every file one time and then get it or copy it to other repos as needed. Right now, I make one "git annex get --auto" in every repo, which is is a waste of time, since most of the files never change anyway! -> The closest we have to this is the (new) `git annex sync --content`. -> It does effectivly just what the shown for loop does. +> Now `git annex sync --content` does effectivly just what the shown for +> loop does. [[done]] > -> But, that actually satisfies preferred content settings, which default -> to preferring every repo have a copy, and even if configured will -> typically be more than numcopies. -> -> Numcopies is more of a minimum lower bound (though not a hard bound). +> The only difference is that copy --auto proactively downloads otherwise +> unwanted files to satisfy numcopies, and sync --content does not. +> We need a [[preferred_content_numcopies_check]] to solve that. > --[[Joey]] diff --git a/doc/todo/preferred_content_numcopies_check.mdwn b/doc/todo/preferred_content_numcopies_check.mdwn new file mode 100644 index 0000000000..956888cca1 --- /dev/null +++ b/doc/todo/preferred_content_numcopies_check.mdwn @@ -0,0 +1,61 @@ +The assistant and git annex sync --content do not try to proactively +download content that is not otherwise wanted in order to get numcopies +satisfied. (Unlike get --auto, which does take numcopies into account.) + +Should these automated systems try to proactively satisfy numcopies? I +don't feel they should. It could result in surprising results. For example, +a transfer repository, which is of limited size, could start being filled +up with lots of content that all clients have, just because numcopies was +set to a larger number than the total number of clients. Another example, +a source repository on eg an Android phone, should never have content in it +that was not created on that device. + +However, it would make sense for some specific +types of repositories to proactively get content to satisfy numcopies. +Currently some types of repositories use "or (not copies=semitrusted+:1)", +to ensure that if the only copy of a file is on a dead repository, they +will try to get that file before the repo goes away. This is done +by client repositories, and backup, and archive. Probably the same set +would make sense to proactively satisfy numcopies. + +So, a new type of preferred content expression is called for. Such as, for +example, "numcopiesneeded=1". Which indicates that at least 1 more copy +is needed to satifsy numcopies. + +(Note that it should only count semittrusted and higher trust +level repos as satisfying numcopies.) + +But, preferred content expressions can only operate on info stored in the +git repo, or they will fail to be stable. Ie, repo A needs to be able to +calculate whether a file is preferred content by repo B and get the same +result as when repo B calculates that. + +numcopies is currently configured in 3 places: + +* .git/config `annex.numcopies` (global, stored only locally) +* .gitattributes `annex.numcopies` (per file, stored in git repo) +* --numcopies (not relevant) + +So, need to add a global numcopies setting that is stored in the git repo. +That could either be a file in the git-annex branch, or just +`* annex.numcopies=2` in the toplevel .gitattributes. Note that the +assistant needs to be able to query and set it, which I think argues +against using .gitattributes for it. Also arguing against that is that the +.git/config numcopies valie applies even to objects with no file in the +work tree, which gitattributes settings do not. + +Conclusion: + +* Add to the git-annex branch a numcopies file that holds the global + numcopies default if present. +* Modify the assistant to use it when configuring numcopies. +* To deprecate .git/config's annex.numcopies, only make it take effect + when there is no numcopies file in the git-annex branch. +* Add "numcopiesneeded=N" preferred content expression using the git-annex + branch numcopies setting, overridden by any .gitattributes numcopies setting + for a particular file. It should ignore the other ways to specify + numcopies. +* Make the repo groups that currently end with "or (not copies=semitrusted+:1)" + to instead end with "or (not numcopiesneeded=1)" + +--[[Joey]] From ecd4c35d7e36c15ef621372244f274c75b600fb4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 14:32:06 -0400 Subject: [PATCH 10/16] promote stm dependency, since Remote.External needs it --- ...nimal_build__39____fails_due_to_missing_stm_dependency.mdwn | 2 ++ doc/install/fromscratch.mdwn | 2 +- git-annex.cabal | 3 +-- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/bugs/__96__minimal_build__39____fails_due_to_missing_stm_dependency.mdwn b/doc/bugs/__96__minimal_build__39____fails_due_to_missing_stm_dependency.mdwn index 7f1dc9c0d7..12a5e0c142 100644 --- a/doc/bugs/__96__minimal_build__39____fails_due_to_missing_stm_dependency.mdwn +++ b/doc/bugs/__96__minimal_build__39____fails_due_to_missing_stm_dependency.mdwn @@ -91,3 +91,5 @@ ExitFailure 1 # End of transcript or log. """]] + +> [[fixed|done]] --[[Joey]] diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 7f78da5378..2c8bf4b714 100644 --- a/doc/install/fromscratch.mdwn +++ b/doc/install/fromscratch.mdwn @@ -25,9 +25,9 @@ quite a lot. * [extensible-exceptions](http://hackage.haskell.org/package/extensible-exceptions) * [feed](http://hackage.haskell.org/package/feed) * [async](http://hackage.haskell.org/package/async) -* Optional haskell stuff, used by the [[assistant]] and its webapp * [stm](http://hackage.haskell.org/package/stm) (version 2.3 or newer) +* Optional haskell stuff, used by the [[assistant]] and its webapp * [hinotify](http://hackage.haskell.org/package/hinotify) (Linux only) * [dbus](http://hackage.haskell.org/package/dbus) diff --git a/git-annex.cabal b/git-annex.cabal index 9b4edf8b2d..a7322e4007 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -93,7 +93,7 @@ Executable git-annex extensible-exceptions, dataenc, SHA, process, json, base (>= 4.5 && < 4.9), monad-control, MonadCatchIO-transformers, IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process, - SafeSemaphore, uuid, random, dlist, unix-compat, async + SafeSemaphore, uuid, random, dlist, unix-compat, async, stm (>= 2.3) CC-Options: -Wall GHC-Options: -Wall Extensions: PackageImports @@ -134,7 +134,6 @@ Executable git-annex CPP-Options: -DWITH_WEBDAV if flag(Assistant) && ! os(solaris) - Build-Depends: stm (>= 2.3) CPP-Options: -DWITH_ASSISTANT if flag(Assistant) From d979f2fbdfa999b83aab84147152d747f4f96863 Mon Sep 17 00:00:00 2001 From: "https://id.koumbit.net/anarcat" Date: Mon, 20 Jan 2014 18:41:59 +0000 Subject: [PATCH 11/16] a separate sync daemon has many advantages indeed --- doc/design/assistant/telehash.mdwn | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn index 01cbd1340c..777bce646e 100644 --- a/doc/design/assistant/telehash.mdwn +++ b/doc/design/assistant/telehash.mdwn @@ -75,7 +75,9 @@ Advantages: (for example, if c-telehash development stalls and the nodejs version is already usable) * Potentially could be generalized to handle other similar protocols. - Or even the xmpp code moved into it. + Or even the xmpp code moved into it. There could even be git-annex native + exchange protocols implemented in such a daemon to allow SSH-less + transfers. * Security holes in telehash would not need to compromise the entire git-annex. gathd could be sandboxed in one way or another. From d66535f065de165ef107ccddaa7cdfa5dfafb5bd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 16:47:56 -0400 Subject: [PATCH 12/16] global numcopies setting * numcopies: New command, sets global numcopies value that is seen by all clones of a repository. * The annex.numcopies git config setting is deprecated. Once the numcopies command is used to set the global number of copies, any annex.numcopies git configs will be ignored. * assistant: Make the prefs page set the global numcopies. This global numcopies setting is needed to let preferred content expressions operate on numcopies. It's also convenient, because typically if you want git-annex to preserve N copies of files in a repo, you want it to do that no matter which repo it's running in. Making it global avoids needing to warn the user about gotchas involving inconsistent annex.numcopies settings. (See changes to doc/numcopies.mdwn.) Added a new variety of git-annex branch log file, that holds only 1 value. Will probably be useful for other stuff later. This commit was sponsored by Nicolas Pouillard. --- Annex.hs | 4 +- Annex/Branch/Transitions.hs | 1 + Annex/Drop.hs | 2 - Assistant/Threads/ConfigMonitor.hs | 2 + Assistant/WebApp/Configurators/Preferences.hs | 6 +- Command.hs | 5 +- Command/Drop.hs | 2 +- Command/Move.hs | 2 +- Command/NumCopies.hs | 56 ++++++++++++++++ Config.hs | 5 +- GitAnnex.hs | 2 + GitAnnex/Options.hs | 2 +- Logs.hs | 13 +++- Logs/NumCopies.hs | 33 ++++++++++ Logs/SingleValue.hs | 65 +++++++++++++++++++ Test.hs | 9 ++- Types/GitConfig.hs | 4 +- debian/changelog | 6 ++ doc/copies.mdwn | 10 +-- doc/git-annex.mdwn | 41 +++++++++--- doc/internals.mdwn | 7 +- .../using_the_web_as_a_special_remote.mdwn | 2 +- .../preferred_content_numcopies_check.mdwn | 6 +- .../fsck:_verifying_your_data.mdwn | 2 +- .../removing_files:_When_things_go_wrong.mdwn | 4 +- 25 files changed, 246 insertions(+), 45 deletions(-) create mode 100644 Command/NumCopies.hs create mode 100644 Logs/NumCopies.hs create mode 100644 Logs/SingleValue.hs diff --git a/Annex.hs b/Annex.hs index d8a2730ba0..d77d0973c4 100644 --- a/Annex.hs +++ b/Annex.hs @@ -94,7 +94,7 @@ data AnnexState = AnnexState , checkattrhandle :: Maybe CheckAttrHandle , checkignorehandle :: Maybe (Maybe CheckIgnoreHandle) , forcebackend :: Maybe String - , forcenumcopies :: Maybe Int + , globalnumcopies :: Maybe Int , limit :: Matcher (MatchInfo -> Annex Bool) , uuidmap :: Maybe UUIDMap , preferredcontentmap :: Maybe PreferredContentMap @@ -129,7 +129,7 @@ newState c r = AnnexState , checkattrhandle = Nothing , checkignorehandle = Nothing , forcebackend = Nothing - , forcenumcopies = Nothing + , globalnumcopies = Nothing , limit = Left [] , uuidmap = Nothing , preferredcontentmap = Nothing diff --git a/Annex/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index 84cd1bbd94..95d47257a3 100644 --- a/Annex/Branch/Transitions.hs +++ b/Annex/Branch/Transitions.hs @@ -41,6 +41,7 @@ dropDead f content trustmap = case getLogVariety f of in if null newlog then RemoveFile else ChangeFile $ Presence.showLog newlog + Just SingleValueLog -> PreserveFile Nothing -> PreserveFile dropDeadFromUUIDBasedLog :: TrustMap -> UUIDBased.Log String -> UUIDBased.Log String diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 6386f11bbf..e307852f22 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -8,7 +8,6 @@ module Annex.Drop where import Common.Annex -import Logs.Location import Logs.Trust import Types.Remote (uuid) import qualified Remote @@ -18,7 +17,6 @@ import Annex.Wanted import Annex.Exception import Config import Annex.Content.Direct -import RunCommand import qualified Data.Set as S import System.Log.Logger (debugM) diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index c180c4da92..8fefc06ebe 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -17,6 +17,7 @@ import Logs.UUID import Logs.Trust import Logs.PreferredContent import Logs.Group +import Logs.NumCopies import Remote.List (remoteListRefresh) import qualified Git.LsTree as LsTree import Git.FilePath @@ -59,6 +60,7 @@ configFilesActions = , (remoteLog, void $ liftAnnex remoteListRefresh) , (trustLog, void $ liftAnnex trustMapLoad) , (groupLog, void $ liftAnnex groupMapLoad) + , (numcopiesLog, void $ liftAnnex numCopiesLoad) , (scheduleLog, void updateScheduleLog) -- Preferred content settings depend on most of the other configs, -- so will be reloaded whenever any configs change. diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs index 385f187113..e9b959e25b 100644 --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -21,6 +21,7 @@ import Utility.DataUnits import Git.Config import Types.Distribution import qualified Build.SysConfig +import Logs.NumCopies import qualified Data.Text as T @@ -81,7 +82,7 @@ prefsAForm def = PrefsForm getPrefs :: Annex PrefsForm getPrefs = PrefsForm <$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig) - <*> (annexNumCopies <$> Annex.getGitConfig) + <*> (maybe deprecatedNumCopies return =<< getGlobalNumCopies) <*> inAutoStartFile <*> (annexAutoUpgrade <$> Annex.getGitConfig) <*> (annexDebug <$> Annex.getGitConfig) @@ -89,7 +90,8 @@ getPrefs = PrefsForm storePrefs :: PrefsForm -> Annex () storePrefs p = do setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p) - setConfig (annexConfig "numcopies") (show $ numCopies p) + setGlobalNumCopies (numCopies p) + unsetConfig (annexConfig "numcopies") -- deprecated setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p) unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do here <- fromRepo Git.repoPath diff --git a/Command.hs b/Command.hs index 555414458e..e3f748dc5e 100644 --- a/Command.hs +++ b/Command.hs @@ -37,6 +37,7 @@ import Checks as ReExported import Usage as ReExported import RunCommand as ReExported import Logs.Trust +import Logs.NumCopies import Config import Annex.CheckAttr @@ -88,8 +89,8 @@ isBareRepo = fromRepo Git.repoIsLocalBare numCopies :: FilePath -> Annex (Maybe Int) numCopies file = do - forced <- Annex.getState Annex.forcenumcopies - case forced of + global <- getGlobalNumCopies + case global of Just n -> return $ Just n Nothing -> readish <$> checkAttr "annex.numcopies" file diff --git a/Command/Drop.hs b/Command/Drop.hs index f5c76f1ce8..97208eff78 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -139,7 +139,7 @@ notEnoughCopies key need have skip bad = do return False where unsafe = showNote "unsafe" - hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)" + hint = showLongNote "(Use --force to override this check, or adjust numcopies.)" {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. diff --git a/Command/Move.hs b/Command/Move.hs index b79e4c9299..b7b5678121 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -64,7 +64,7 @@ showMoveAction False key Nothing = showStart "copy" (key2file key) - 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. + - Note that unlike drop, this does not honor numcopies. - A file's content can be moved even if there are insufficient copies to - allow it to be dropped. -} diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs new file mode 100644 index 0000000000..804faff58c --- /dev/null +++ b/Command/NumCopies.hs @@ -0,0 +1,56 @@ +{- git-annex command + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.NumCopies where + +import Common.Annex +import qualified Annex +import Command +import Logs.NumCopies +import Types.Messages + +def :: [Command] +def = [command "numcopies" paramNumber seek + SectionSetup "configure desired number of copies"] + +seek :: CommandSeek +seek = withWords start + +start :: [String] -> CommandStart +start [] = startGet +start [s] = do + case readish s of + Nothing -> error $ "Bad number: " ++ s + Just n + | n > 0 -> startSet n + | n == 0 -> ifM (Annex.getState Annex.force) + ( startSet n + , error "Setting numcopies to 0 is very unsafe. You will lose data! If you really want to do that, specify --force." + ) + | otherwise -> error "Number cannot be negative!" +start _ = error "Specify a single number." + +startGet :: CommandStart +startGet = next $ next $ do + Annex.setOutput QuietOutput + v <- getGlobalNumCopies + case v of + Just n -> liftIO $ putStrLn $ show n + Nothing -> do + liftIO $ putStrLn $ "global numcopies is not set" + old <- annexNumCopies <$> Annex.getGitConfig + case old of + Nothing -> liftIO $ putStrLn "(default is 1)" + Just n -> liftIO $ putStrLn $ "(deprecated git config annex.numcopies is set to " ++ show n ++ " locally)" + return True + +startSet :: Int -> CommandStart +startSet n = do + showStart "numcopies" (show n) + next $ next $ do + setGlobalNumCopies n + return True diff --git a/Config.hs b/Config.hs index 5003c1ce09..0ccf1b5c0f 100644 --- a/Config.hs +++ b/Config.hs @@ -71,7 +71,10 @@ setRemoteAvailability r c = setConfig (remoteConfig r "availability") (show c) getNumCopies :: Maybe Int -> Annex Int getNumCopies (Just v) = return v -getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig +getNumCopies Nothing = deprecatedNumCopies + +deprecatedNumCopies :: Annex Int +deprecatedNumCopies = fromMaybe 1 . annexNumCopies <$> Annex.getGitConfig isDirect :: Annex Bool isDirect = annexDirect <$> Annex.getGitConfig diff --git a/GitAnnex.hs b/GitAnnex.hs index 4c1649ba14..57ee5d5204 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -50,6 +50,7 @@ import qualified Command.Info import qualified Command.Status import qualified Command.Migrate import qualified Command.Uninit +import qualified Command.NumCopies import qualified Command.Trust import qualified Command.Untrust import qualified Command.Semitrust @@ -117,6 +118,7 @@ cmds = concat , Command.Unannex.def , Command.Uninit.def , Command.PreCommit.def + , Command.NumCopies.def , Command.Trust.def , Command.Untrust.def , Command.Semitrust.def diff --git a/GitAnnex/Options.hs b/GitAnnex/Options.hs index 45b9539e0d..fbb34470b5 100644 --- a/GitAnnex/Options.hs +++ b/GitAnnex/Options.hs @@ -63,7 +63,7 @@ options = Option.common ++ where trustArg t = ReqArg (Remote.forceTrust t) paramRemote setnumcopies v = maybe noop - (\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just n }) + (\n -> Annex.changeState $ \s -> s { Annex.globalnumcopies = Just n }) (readish v) setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } setgitconfig v = inRepo (Git.Config.store v) diff --git a/Logs.hs b/Logs.hs index 2952d6920c..828a73dc70 100644 --- a/Logs.hs +++ b/Logs.hs @@ -11,7 +11,11 @@ import Common.Annex import Types.Key {- There are several varieties of log file formats. -} -data LogVariety = UUIDBasedLog | NewUUIDBasedLog | PresenceLog Key +data LogVariety + = UUIDBasedLog + | NewUUIDBasedLog + | PresenceLog Key + | SingleValueLog deriving (Show) {- Converts a path from the git-annex branch into one of the varieties @@ -20,6 +24,7 @@ getLogVariety :: FilePath -> Maybe LogVariety getLogVariety f | f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog | isRemoteStateLog f = Just NewUUIDBasedLog + | f == numcopiesLog = Just SingleValueLog | otherwise = PresenceLog <$> firstJust (presenceLogs f) {- All the uuid-based logs stored in the top of the git-annex branch. -} @@ -43,6 +48,9 @@ presenceLogs f = uuidLog :: FilePath uuidLog = "uuid.log" +numcopiesLog :: FilePath +numcopiesLog = "numcopies.log" + remoteLog :: FilePath remoteLog = "remote.log" @@ -118,6 +126,7 @@ prop_logs_sane dummykey = all id , expect isPresenceLog (getLogVariety $ locationLogFile dummykey) , expect isPresenceLog (getLogVariety $ urlLogFile dummykey) , expect isNewUUIDBasedLog (getLogVariety $ remoteStateLogFile dummykey) + , expect isSingleValueLog (getLogVariety $ numcopiesLog) ] where expect = maybe False @@ -127,3 +136,5 @@ prop_logs_sane dummykey = all id isNewUUIDBasedLog _ = False isPresenceLog (PresenceLog k) = k == dummykey isPresenceLog _ = False + isSingleValueLog SingleValueLog = True + isSingleValueLog _ = False diff --git a/Logs/NumCopies.hs b/Logs/NumCopies.hs new file mode 100644 index 0000000000..dc345dd0aa --- /dev/null +++ b/Logs/NumCopies.hs @@ -0,0 +1,33 @@ +{- git-annex numcopies log + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Logs.NumCopies where + +import Common.Annex +import qualified Annex +import Logs +import Logs.SingleValue + +instance Serializable Int where + serialize = show + deserialize = readish + +setGlobalNumCopies :: Int -> Annex () +setGlobalNumCopies = setLog numcopiesLog + +{- Cached for speed. -} +getGlobalNumCopies :: Annex (Maybe Int) +getGlobalNumCopies = maybe numCopiesLoad (return . Just) + =<< Annex.getState Annex.globalnumcopies + +numCopiesLoad :: Annex (Maybe Int) +numCopiesLoad = do + v <- getLog numcopiesLog + Annex.changeState $ \s -> s { Annex.globalnumcopies = v } + return v diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs new file mode 100644 index 0000000000..03975df927 --- /dev/null +++ b/Logs/SingleValue.hs @@ -0,0 +1,65 @@ +{- git-annex single-value log + - + - This is used to store a value in a way that can be union merged. + - + - A line of the log will look like: "timestamp value" + - + - The line with the newest timestamp wins. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Logs.SingleValue where + +import Common.Annex +import qualified Annex.Branch + +import qualified Data.Set as S +import Data.Time.Clock.POSIX +import Data.Time +import System.Locale + +class Serializable v where + serialize :: v -> String + deserialize :: String -> Maybe v + +data LogEntry v = LogEntry + { changed :: POSIXTime + , value :: v + } deriving (Eq, Show, Ord) + +type Log v = S.Set (LogEntry v) + +showLog :: (Serializable v) => Log v -> String +showLog = unlines . map showline . S.toList + where + showline (LogEntry t v) = unwords [show t, serialize v] + +parseLog :: (Ord v, Serializable v) => String -> Log v +parseLog = S.fromList . mapMaybe parse . lines + where + parse line = do + let (ts, s) = splitword line + date <- utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" ts + v <- deserialize s + Just (LogEntry date v) + splitword = separate (== ' ') + +newestValue :: Log v -> Maybe v +newestValue s + | S.null s = Nothing + | otherwise = Just (value $ S.findMax s) + +readLog :: (Ord v, Serializable v) => FilePath -> Annex (Log v) +readLog = parseLog <$$> Annex.Branch.get + +getLog :: (Ord v, Serializable v) => FilePath -> Annex (Maybe v) +getLog = newestValue <$$> readLog + +setLog :: (Serializable v) => FilePath -> v -> Annex () +setLog f v = do + now <- liftIO getPOSIXTime + let ent = LogEntry now v + Annex.Branch.change f $ \_old -> showLog (S.singleton ent) diff --git a/Test.hs b/Test.hs index 2f632f61d1..7424a5b96f 100644 --- a/Test.hs +++ b/Test.hs @@ -292,6 +292,9 @@ test_drop_withremote :: TestEnv -> Assertion test_drop_withremote env = intmpclonerepo env $ do git_annex env "get" [annexedfile] @? "get failed" annexed_present annexedfile + git_annex env "numcopies" ["2"] @? "numcopies config failed" + not <$> git_annex env "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied" + git_annex env "numcopies" ["1"] @? "numcopies config failed" git_annex env "drop" [annexedfile] @? "drop failed though origin has copy" annexed_notpresent annexedfile inmainrepo env $ annexed_present annexedfile @@ -511,9 +514,9 @@ test_trust env = intmpclonerepo env $ do test_fsck_basic :: TestEnv -> Assertion test_fsck_basic env = intmpclonerepo env $ do git_annex env "fsck" [] @? "fsck failed" - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + git_annex env "numcopies" ["2"] @? "numcopies config failed" fsck_should_fail env "numcopies unsatisfied" - boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" + git_annex env "numcopies" ["1"] @? "numcopies config failed" corrupt annexedfile corrupt sha1annexedfile where @@ -542,7 +545,7 @@ test_fsck_localuntrusted env = intmpclonerepo env $ do test_fsck_remoteuntrusted :: TestEnv -> Assertion test_fsck_remoteuntrusted env = intmpclonerepo env $ do - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + git_annex env "numcopies" ["2"] @? "numcopies config failed" git_annex env "get" [annexedfile] @? "get failed" git_annex env "get" [sha1annexedfile] @? "get failed" git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index cda53f229a..5cd09dbde5 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -24,7 +24,7 @@ import Types.Availability - such as annex.foo -} data GitConfig = GitConfig { annexVersion :: Maybe String - , annexNumCopies :: Int + , annexNumCopies :: Maybe Int , annexDiskReserve :: Integer , annexDirect :: Bool , annexBackends :: [String] @@ -52,7 +52,7 @@ data GitConfig = GitConfig extractGitConfig :: Git.Repo -> GitConfig extractGitConfig r = GitConfig { annexVersion = notempty $ getmaybe (annex "version") - , annexNumCopies = get (annex "numcopies") 1 + , annexNumCopies = getmayberead (annex "numcopies") , annexDiskReserve = fromMaybe onemegabyte $ readSize dataUnits =<< getmaybe (annex "diskreserve") , annexDirect = getbool (annex "direct") False diff --git a/debian/changelog b/debian/changelog index d41fe5e6df..9ecb4d2b6e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,12 @@ git-annex (5.20140118) UNRELEASED; urgency=medium * list: Fix specifying of files to list. * Allow --all to be mixed with matching options like --copies and --in (but not --include and --exclude). + * numcopies: New command, sets global numcopies value that is seen by all + clones of a repository. + * The annex.numcopies git config setting is deprecated. Once the numcopies + command is used to set the global number of copies, any annex.numcopies + git configs will be ignored. + * assistant: Make the prefs page set the global numcopies. -- Joey Hess Sat, 18 Jan 2014 11:54:17 -0400 diff --git a/doc/copies.mdwn b/doc/copies.mdwn index 93cbd8ea80..205d2d5b12 100644 --- a/doc/copies.mdwn +++ b/doc/copies.mdwn @@ -6,8 +6,8 @@ command. So, git-annex can be configured to try to keep N copies of a file's content available across all repositories. (Although [[untrusted_repositories|trust]] don't count toward this total.) -By default, N is 1; it is configured by annex.numcopies. This default -can be overridden on a per-file-type basis by the annex.numcopies +By default, N is 1; it is configured by running `git annex numcopies N`. +This default can be overridden on a per-file-type basis by the annex.numcopies setting in `.gitattributes` files. The --numcopies switch allows temporarily using a different value. @@ -30,9 +30,3 @@ refuse to do so. With N=2, in order to drop the file content from Laptop, it would need access to both USB and Server. - -Note that different repositories can be configured with different values of -N. So just because Laptop has N=2, this does not prevent the number of -copies falling to 1, when USB and Server have N=1. To avoid this, -configure it in `.gitattributes`, which is shared between repositories -using git. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index e8058720c0..4e7bd23958 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -403,6 +403,20 @@ subdirectories). keyid+= and keyid-= with such remotes should be used with care, and make little sense except in cases like the revoked key example above. +* `numcopies [N]` + + Tells git-annex how many copies it should preserve of files, over all + repositories. The default is 1. + + Run without a number to get the current value. + + When git-annex is asked to drop a file, it first verifies that the + required number of copies can be satisfied amoung all the other + repositories that have a copy of the file. + + This can be overridden on a per-file basis by the annex.numcopies setting + in .gitattributes files. + * `trust [repository ...]` Records that a repository is trusted to not unexpectedly lose @@ -828,7 +842,7 @@ subdirectories). * `--auto` Enable automatic mode. Commands that get, drop, or move file contents - will only do so when needed to help satisfy the setting of annex.numcopies, + will only do so when needed to help satisfy the setting of numcopies, and preferred content configuration. * `--all` @@ -883,7 +897,7 @@ subdirectories). * `--numcopies=n` - Overrides the `annex.numcopies` setting, forcing git-annex to ensure the + Overrides the numcopies setting, forcing git-annex to ensure the specified number of copies exist. Note that setting numcopies to 0 is very unsafe. @@ -1117,12 +1131,6 @@ Here are all the supported configuration settings. A unique UUID for this repository (automatically set). -* `annex.numcopies` - - Number of copies of files to keep across all repositories. (default: 1) - - Note that setting numcopies to 0 is very unsafe. - * `annex.backends` Space-separated list of names of the key-value backends to use. @@ -1151,6 +1159,17 @@ Here are all the supported configuration settings. annex.largefiles = largerthan=100kb and not (include=*.c or include=*.h) +* `annex.numcopies` + + This is a deprecated setting. You should instead use the + `git annex numcopies` command to configure how many copies of files + are kept acros all repositories. + + This config setting is only looked at when `git annex numcopies` has + never been configured. + + Note that setting numcopies to 0 is very unsafe. + * `annex.queuesize` git-annex builds a queue of git commands, in order to combine similar @@ -1456,10 +1475,12 @@ but the SHA256E backend for ogg files: The numcopies setting can also be configured on a per-file-type basis via the `annex.numcopies` attribute in `.gitattributes` files. This overrides -any value set using `annex.numcopies` in `.git/config`. -For example, this makes two copies be needed for wav files: +other numcopies settings. +For example, this makes two copies be needed for wav files and 3 copies +for flac files: *.wav annex.numcopies=2 + *.flac annex.numcopies=3 Note that setting numcopies to 0 is very unsafe. diff --git a/doc/internals.mdwn b/doc/internals.mdwn index d95ab3f5ef..1cf0cf5051 100644 --- a/doc/internals.mdwn +++ b/doc/internals.mdwn @@ -56,8 +56,11 @@ space and then the description, followed by a timestamp. Example: e605dca6-446a-11e0-8b2a-002170d25c55 laptop timestamp=1317929189.157237s 26339d22-446b-11e0-9101-002170d25c55 usb disk timestamp=1317929330.769997s -If there are multiple lines for the same uuid, the one with the most recent -timestamp wins. git-annex union merges this and other files. +## `numcopies.log` + +Records the global numcopies setting. + +The file format is simply a timestamp followed by a number. ## `remote.log` diff --git a/doc/tips/using_the_web_as_a_special_remote.mdwn b/doc/tips/using_the_web_as_a_special_remote.mdwn index 706ae2951d..62ef58b694 100644 --- a/doc/tips/using_the_web_as_a_special_remote.mdwn +++ b/doc/tips/using_the_web_as_a_special_remote.mdwn @@ -34,7 +34,7 @@ With the result that it will hang onto files: Could only verify the existence of 0 out of 1 necessary copies Also these untrusted repositories may contain the file: 00000000-0000-0000-0000-000000000001 -- web - (Use --force to override this check, or adjust annex.numcopies.) + (Use --force to override this check, or adjust numcopies.) failed ## attaching urls to existing files diff --git a/doc/todo/preferred_content_numcopies_check.mdwn b/doc/todo/preferred_content_numcopies_check.mdwn index 956888cca1..066f02cfb6 100644 --- a/doc/todo/preferred_content_numcopies_check.mdwn +++ b/doc/todo/preferred_content_numcopies_check.mdwn @@ -47,10 +47,10 @@ work tree, which gitattributes settings do not. Conclusion: * Add to the git-annex branch a numcopies file that holds the global - numcopies default if present. -* Modify the assistant to use it when configuring numcopies. + numcopies default if present. **done** +* Modify the assistant to use it when configuring numcopies. **done** * To deprecate .git/config's annex.numcopies, only make it take effect - when there is no numcopies file in the git-annex branch. + when there is no numcopies file in the git-annex branch. **done** * Add "numcopiesneeded=N" preferred content expression using the git-annex branch numcopies setting, overridden by any .gitattributes numcopies setting for a particular file. It should ignore the other ways to specify diff --git a/doc/walkthrough/fsck:_verifying_your_data.mdwn b/doc/walkthrough/fsck:_verifying_your_data.mdwn index d036332fb3..62e15b6fa5 100644 --- a/doc/walkthrough/fsck:_verifying_your_data.mdwn +++ b/doc/walkthrough/fsck:_verifying_your_data.mdwn @@ -2,7 +2,7 @@ You can use the fsck subcommand to check for problems in your data. What can be checked depends on the key-value [[backend|backends]] you've used for the data. For example, when you use the SHA1 backend, fsck will verify that the checksums of your files are good. Fsck also checks that the -annex.numcopies setting is satisfied for all files. +[[numcopies|copies]] setting is satisfied for all files. # git annex fsck fsck some_file (checksum...) ok diff --git a/doc/walkthrough/removing_files:_When_things_go_wrong.mdwn b/doc/walkthrough/removing_files:_When_things_go_wrong.mdwn index 2d3c0cde08..ccd2d197f5 100644 --- a/doc/walkthrough/removing_files:_When_things_go_wrong.mdwn +++ b/doc/walkthrough/removing_files:_When_things_go_wrong.mdwn @@ -10,12 +10,12 @@ you'll see something like this. Try making some of these repositories available: 58d84e8a-d9ae-11df-a1aa-ab9aa8c00826 -- portable USB drive ca20064c-dbb5-11df-b2fe-002170d25c55 -- backup SATA drive - (Use --force to override this check, or adjust annex.numcopies.) + (Use --force to override this check, or adjust numcopies.) failed drop other.iso (unsafe) Could only verify the existence of 0 out of 1 necessary copies No other repository is known to contain the file. - (Use --force to override this check, or adjust annex.numcopies.) + (Use --force to override this check, or adjust numcopies.) failed Here you might --force it to drop `important_file` if you [[trust]] your backup. From 5ddbd24a1c8853f87da967f854cf5f880c5df492 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 17:11:02 -0400 Subject: [PATCH 13/16] stability analysis --- .../preferred_content_numcopies_check.mdwn | 22 ++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/doc/todo/preferred_content_numcopies_check.mdwn b/doc/todo/preferred_content_numcopies_check.mdwn index 066f02cfb6..152afe08c8 100644 --- a/doc/todo/preferred_content_numcopies_check.mdwn +++ b/doc/todo/preferred_content_numcopies_check.mdwn @@ -56,6 +56,26 @@ Conclusion: for a particular file. It should ignore the other ways to specify numcopies. * Make the repo groups that currently end with "or (not copies=semitrusted+:1)" - to instead end with "or (not numcopiesneeded=1)" + to instead end with "or numcopiesneeded=1" + +## Stability analysis + +If a remote prefers eg, "blah or numcopiesneeded=1", and +file $foo does not match blah, but needs more copies, then then the +expression will match. + +So, git-annex will get $foo, adding a copy. Which means that the +numcopiesneeded=1 will no longer match, so the file is no longer wanted +now that it has been downloaded. + +Now there are two cases for what can happen: + +* git-annex tries to drop $foo, but fails because it cannot find enough + other copies +* git-annex copies $foo to some other remote that wants it, and then + manages to drop $foo from the local remote. + +This seems ok. Files flow through repos and they act like transfer +repos when there are not enough copies. --[[Joey]] From 3159da26936105dbb86ac181ab2d414a409b083a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 17:34:58 -0400 Subject: [PATCH 14/16] Add and use numcopiesneeded preferred content expression. * Add numcopiesneeded preferred content expression. * Client, transfer, incremental backup, and archive repositories now want to get content that does not yet have enough copies. This means the asssistant will make copies of files that don't yet meet the configured numcopies, even to places that would not normally want the file. For example, if numcopies is 4, and there are 2 client repos and 2 transfer repos, and 2 removable backup drives, the file will be sent to both transfer repos in order to make 4 copies. Once a removable drive get a copy of the file, it will be dropped from one transfer repo or the other (but not both). Another example, numcopies is 3 and there is a client that has a backup removable drive and two small archive repos. Normally once one of the small archives has a file, it will not be put into the other one. But, to satisfy numcopies, the assistant will duplicate it into the other small archive too, if the backup repo is not available to receive the file. I notice that these examples are fairly unlikely setups .. the old behavior was not too bad, but it's nice to finally have it really correct. .. Almost. I have skipped checking the annex.numcopies .gitattributes out of fear it will be too slow. This commit was sponsored by Florian Schlegel. --- Annex/FileMatcher.hs | 1 + GitAnnex/Options.hs | 2 ++ Limit.hs | 27 ++++++++++++++++++- Types/StandardGroups.hs | 4 +-- debian/changelog | 3 +++ doc/git-annex.mdwn | 9 +++++++ doc/preferred_content.mdwn | 8 +++--- .../preferred_content_numcopies_check.mdwn | 7 +++-- 8 files changed, 52 insertions(+), 9 deletions(-) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 96cb8fd6f1..6ec0bace94 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -70,6 +70,7 @@ parseToken checkpresent checkpreferreddir groupmap t [ ("include", limitInclude) , ("exclude", limitExclude) , ("copies", limitCopies) + , ("numcopiesneeded", limitNumCopiesNeeded) , ("inbackend", limitInBackend) , ("largerthan", limitSize (>)) , ("smallerthan", limitSize (<)) diff --git a/GitAnnex/Options.hs b/GitAnnex/Options.hs index fbb34470b5..ad1e0c93b4 100644 --- a/GitAnnex/Options.hs +++ b/GitAnnex/Options.hs @@ -41,6 +41,8 @@ options = Option.common ++ "match files present in a remote" , Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber) "skip files with fewer copies" + , Option [] ["numcopiesneeded"] (ReqArg Limit.addNumCopiesNeeded paramNumber) + "match files that need more copies" , Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName) "match files using a key-value backend" , Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup) diff --git a/Limit.hs b/Limit.hs index fa6fa1f412..c0d32c68eb 100644 --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -23,6 +23,7 @@ import qualified Backend import Annex.Content import Annex.UUID import Logs.Trust +import Logs.NumCopies import Types.TrustLevel import Types.Key import Types.Group @@ -177,6 +178,30 @@ limitCopies want = case split ":" want of | "+" `isSuffixOf` s = (>=) <$> readTrustLevel (beginning s) | otherwise = (==) <$> readTrustLevel s +{- Adds a limit to match files that need more copies made. + - + - Does not look at annex.numcopies .gitattributes, because that + - would require querying git check-attr every time a preferred content + - expression is checked, which would probably be quite slow. + -} +addNumCopiesNeeded :: String -> Annex () +addNumCopiesNeeded = addLimit . limitNumCopiesNeeded + +limitNumCopiesNeeded :: MkLimit +limitNumCopiesNeeded want = case readish want of + Just needed -> Right $ \notpresent -> checkKey $ + handle needed notpresent + Nothing -> Left "bad value for numcopiesneeded" + where + handle needed notpresent key = do + gv <- getGlobalNumCopies + case gv of + Nothing -> return False + Just numcopies -> do + us <- filter (`S.notMember` notpresent) + <$> (trustExclude UnTrusted =<< Remote.keyLocations key) + return $ numcopies - length us >= needed + {- Adds a limit to skip files not believed to be present in all - repositories in the specified group. -} addInAllGroup :: String -> Annex () diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 51788ec4e9..c4c3ba9f3f 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -93,6 +93,6 @@ notArchived :: String notArchived = "not (copies=archive:1 or copies=smallarchive:1)" {- Most repositories want any content that is only on untrusted - - or dead repositories. -} + - or dead repositories, or that otherwise does not have enough copies. -} lastResort :: String -> PreferredContentExpression -lastResort s = "(" ++ s ++ ") or (not copies=semitrusted+:1)" +lastResort s = "(" ++ s ++ ") or numcopiesneeded=1" diff --git a/debian/changelog b/debian/changelog index 9ecb4d2b6e..923fb1692f 100644 --- a/debian/changelog +++ b/debian/changelog @@ -14,6 +14,9 @@ git-annex (5.20140118) UNRELEASED; urgency=medium command is used to set the global number of copies, any annex.numcopies git configs will be ignored. * assistant: Make the prefs page set the global numcopies. + * Add numcopiesneeded preferred content expression. + * Client, transfer, incremental backup, and archive repositories + now want to get content that does not yet have enough copies. -- Joey Hess Sat, 18 Jan 2014 11:54:17 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 4e7bd23958..8a948d303e 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1020,6 +1020,15 @@ file contents are present at either of two repositories. copies, on remotes in the specified group. For example, `--copies=archive:2` +* `--numcopiesneeded=number` + + Matches only files that git-annex believes need the specified number or + more additional copies to be made in order to satisfy their numcopies + setting, as configured by the global numcopies setting of the repository. + + Note that for various reasons, including speed, this does not look + at the annex.numcopies .gitattributes settings of files. + * `--inbackend=name` Matches only files whose content is stored using the specified key-value diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn index 9c698c8ba7..b18f46c335 100644 --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -113,7 +113,7 @@ any repository that can will back it up.) All content is preferred, unless it's for a file in a "archive" directory, which has reached an archive repository. -`((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) or (not copies=semitrusted+:1)` +`((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) or numcopiesneeded=1` ### transfer @@ -147,20 +147,20 @@ All content is preferred. Only prefers content that's not already backed up to another backup or incremental backup repository. -`(include=* and (not copies=backup:1) and (not copies=incrementalbackup:1)) or (not copies=semitrusted+:1)` +`(include=* and (not copies=backup:1) and (not copies=incrementalbackup:1)) or numcopiesneeded=1` ### small archive Only prefers content that's located in an "archive" directory, and only if it's not already been archived somewhere else. -`((include=*/archive/* or include=archive/*) and not (copies=archive:1 or copies=smallarchive:1)) or (not copies=semitrusted+:1)` +`((include=*/archive/* or include=archive/*) and not (copies=archive:1 or copies=smallarchive:1)) or numcopiesneeded=1` ### full archive All content is preferred, unless it's already been archived somewhere else. -`(not (copies=archive:1 or copies=smallarchive:1)) or (not copies=semitrusted+:1)` +`(not (copies=archive:1 or copies=smallarchive:1)) or numcopiesneeded=1` Note that if you want to archive multiple copies (not a bad idea!), you should instead configure all your archive repositories with a diff --git a/doc/todo/preferred_content_numcopies_check.mdwn b/doc/todo/preferred_content_numcopies_check.mdwn index 152afe08c8..8aa736a045 100644 --- a/doc/todo/preferred_content_numcopies_check.mdwn +++ b/doc/todo/preferred_content_numcopies_check.mdwn @@ -54,9 +54,12 @@ Conclusion: * Add "numcopiesneeded=N" preferred content expression using the git-annex branch numcopies setting, overridden by any .gitattributes numcopies setting for a particular file. It should ignore the other ways to specify - numcopies. + numcopies, particularly git config annex.numcopies. **done** * Make the repo groups that currently end with "or (not copies=semitrusted+:1)" - to instead end with "or numcopiesneeded=1" + to instead end with "or numcopiesneeded=1" **done** +* See if "numcopiesneeded=N" can check .gitattributes without getting + a lot slower. If now, perhaps add a "numcopiesneededaccurate=N" that + checks it. ## Stability analysis From df66e15555a4898a1cceb0dbbda620c0f2e310c6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 20 Jan 2014 17:47:17 -0400 Subject: [PATCH 15/16] devblog --- doc/devblog/day_101__old_mistakes.mdwn | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 doc/devblog/day_101__old_mistakes.mdwn diff --git a/doc/devblog/day_101__old_mistakes.mdwn b/doc/devblog/day_101__old_mistakes.mdwn new file mode 100644 index 0000000000..4a37416dc4 --- /dev/null +++ b/doc/devblog/day_101__old_mistakes.mdwn @@ -0,0 +1,23 @@ +In order to remove some hackishness in `git annex sync --content`, I +finally fixed a bad design decision I made back at the very beginning +(before I really knew haskell) when I built the command seek code, which +had led to a kind of inversion of control. This took most of a night, but +it made a lot of code in git-annex clearer, and it makes the command +seeking code much more flexible in what it can do. Some of the oldest, and +worst code in git-annex was removed in the process. + +Also, I've been reworking the numcopies configuration, to allow for a +[[todo/preferred_content_numcopies_check]]. That will let the assistant, +as well as `git annex sync --content` proactively make copies when +needed in order to satisfy numcopies. + +As part of this, `git config annex.numcopies` is deprecated, and there's a +new `git annex numcopies N` command that sets the numcopies value that will +be used by any clone of a repository. + +I got the preferred content checking of numcopies working too. However, +I am unsure if checking for per-file .gitattributes annex.numcopies +settings will make preferred content expressions be, so I have left +that out for now. + +Today's work was sponsored by Josh Taylor. From f11ccc16a6b9a41011628fdff5cda9508e53fac1 Mon Sep 17 00:00:00 2001 From: "https://www.google.com/accounts/o8/id?id=AItOawkLdR1fuu5aEz3s9VKTBKVMize_SmeNRJM" Date: Mon, 20 Jan 2014 23:14:53 +0000 Subject: [PATCH 16/16] Added a comment: Past the SHA issues --- ..._1a0e174969e99e7b562854d2c3b3e606._comment | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 doc/bugs/Share_with_friends_crash_in_osx/comment_11_1a0e174969e99e7b562854d2c3b3e606._comment diff --git a/doc/bugs/Share_with_friends_crash_in_osx/comment_11_1a0e174969e99e7b562854d2c3b3e606._comment b/doc/bugs/Share_with_friends_crash_in_osx/comment_11_1a0e174969e99e7b562854d2c3b3e606._comment new file mode 100644 index 0000000000..5b5b94a401 --- /dev/null +++ b/doc/bugs/Share_with_friends_crash_in_osx/comment_11_1a0e174969e99e7b562854d2c3b3e606._comment @@ -0,0 +1,19 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawkLdR1fuu5aEz3s9VKTBKVMize_SmeNRJM" + nickname="David" + subject="Past the SHA issues" + date="2014-01-20T23:14:53Z" + content=""" +Now we still have an issue with nettle, but now it's part of urandom. I'm not sure what to suggest... + +[[!format sh \"\"\" +Thread 1 Crashed: +0 H 0x00000001075d9756 do_device_source_urandom + 108 +1 H 0x00000001075d9686 do_device_source + 46 +2 H 0x00000001075d92b9 wrap_nettle_rnd_init + 74 +3 H 0x000000010755d585 _gnutls_rnd_init + 32 +4 H 0x0000000107551dae gnutls_global_init + 262 +5 git-annex 0x00000001054a28c3 0x103c83000 + 25295043 +6 git-annex 0x000000010692ab28 0x103c83000 + 46824232 +\"\"\"]] +"""]]