diff options
115 files changed, 921 insertions, 453 deletions
@@ -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 @@ -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 @@ -128,7 +129,7 @@ newState c r = AnnexState , checkattrhandle = Nothing , checkignorehandle = Nothing , forcebackend = Nothing - , forcenumcopies = Nothing + , globalnumcopies = Nothing , limit = Left [] , uuidmap = Nothing , preferredcontentmap = Nothing @@ -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/Branch/Transitions.hs b/Annex/Branch/Transitions.hs index 84cd1bbd9..95d47257a 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 df64895be..e307852f2 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 @@ -27,29 +26,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. + - 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. - -} -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 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. - - 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 +86,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 $ runner $ a (Just numcopies)) ( do liftIO $ debugM "drop" $ unwords [ "dropped" @@ -113,6 +107,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/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 96cb8fd6f..6ec0bace9 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/Assistant/Drop.hs b/Assistant/Drop.hs index 03ab5ab2c..3020b0f4f 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/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index c180c4da9..8fefc06eb 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/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index b00195789..60f6dc28b 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/CmdLine.hs b/CmdLine.hs index 7c28ecec8..cba403dc2 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 b6484749e..e3f748dc5 100644 --- a/Command.hs +++ b/Command.hs @@ -1,10 +1,12 @@ {- git-annex command infrastructure - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Command ( command, noRepo, @@ -14,8 +16,6 @@ module Command ( next, stop, stopUnless, - prepCommand, - doCommand, whenAnnexed, ifAnnexed, isBareRepo, @@ -35,12 +35,14 @@ 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 Logs.NumCopies 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) @@ -106,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/Add.hs b/Command/Add.hs index c5035ba1f..ffa27504a 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 1a178e8d4..91427e819 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 7f3607b81..8027c4b6b 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 cef4392dc..260d9c69c 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 6f3f9df28..f5f13d248 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 c42480200..58b738864 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 9fd97334a..fd16cea29 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 180f2fda9..13aa74bff 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 18851b172..601b3fcc9 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 c35bbdaea..47f622a81 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 4c7128603..97208eff7 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 -> @@ -138,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/DropKey.hs b/Command/DropKey.hs index 624919584..002633e58 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 bf2635e00..5d7c5c1d2 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 1905acd8d..a00046d5a 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 1e8e2cecf..30963287e 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 ddcc4b8c7..e7e5b7986 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 a63a10f8f..9339585d1 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 74bd68ad1..0f247f968 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 c3d2daafe..784731ad7 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 2ab47b562..8b320f209 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 - ] - -withIncremental :: (Incremental -> CommandSeek) -> CommandSeek -withIncremental = withValue $ do +seek :: CommandSeek +seek ps = do + from <- getOptionField fromOption Remote.byNameWithUUID + i <- getIncremental + withKeyOptions + (startKey i) + (withFilesInGit $ whenAnnexed $ start from i) + ps + +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 34e74b433..2ed0fed62 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 bdd770f15..2448467fd 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 52fbd25f9..c83692a8d 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 4c0bf4899..b0dbc1465 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 71e767663..5292c3ca3 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 dcf2b0fa0..dda2f3bc4 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 d16362205..2675b7a54 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 4410d722d..11cbdb73d 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 a8669fe50..194be6821 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 b623d58e7..fde51968d 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 3db9a6be3..a076cb486 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 5a240f800..79fbcf39c 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 663da4500..763908116 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 bceba4a91..e6733dcb1 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 f3a5becb8..b7ad664cf 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 aa83266cb..814c5d2d7 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 575e32122..9b80d2035 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 31db7a99f..51a8b9c52 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 0fdf0e817..c14c07bdd 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 fb829bcb0..cf4663cb5 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 7d11b5abd..b7b567812 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 @@ -63,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 000000000..804faff58 --- /dev/null +++ b/Command/NumCopies.hs @@ -0,0 +1,56 @@ +{- git-annex command + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - 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/Command/PreCommit.hs b/Command/PreCommit.hs index eed2f491c..6644f6ffa 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 7448ba97e..805300f9f 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 3b2a8c496..6964ea5bd 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 c49af0060..1609c6097 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 0f02a3ab3..c87317685 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 d3ded38a3..3f304b76e 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 db654f291..a088dbef8 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 e20563672..26ce6961b 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 24b1821c3..488480e0a 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 27127b3ec..462d68e05 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 1b5082700..9db3c7ad7 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,18 +77,18 @@ 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 + -- Syncing involves many actions, any of which can independently + -- fail, without preventing the others from running. + seekActions $ return $ concat [ [ commit ] , [ withbranch mergeLocal ] , map (withbranch . pullRemote) gitremotes - , [ mergeAnnex ] - , synccontent - , [ withbranch pushLocal ] + , [ mergeAnnex ] + ] + whenM (Annex.getFlag $ Option.name contentOption) $ + seekSyncContent remotes + seekActions $ return $ concat + [ [ withbranch pushLocal ] , map (withbranch . pushRemote) gitremotes ] @@ -499,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 - - let results = getresults ++ putresults - if null results - then stop - else do - showStart "sync" f - next $ next $ return $ all id results - where - run a = do - r <- a - showEndResult r - return r + sequence_ =<< handleget have + putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack) + + -- 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 wantget have = allM id [ pure (not $ null have) , not <$> inAnnex k @@ -531,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 @@ -543,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/Command/Test.hs b/Command/Test.hs index be480eeb7..47d72ee44 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 93f6c7077..796503133 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 41a207080..f3856eb2e 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 6d8db4ef2..9c05702be 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 26993ef77..3898af347 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 5e3c4279a..1f2978430 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 a6557f21d..a88e3f7c8 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 3fbe6758a..f608d03fe 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 1eba26ff7..9f2c257fb 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 f18637838..cde1eee93 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 f99528cfa..19dc82007 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 de34278dd..80876290a 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 0326b9ede..526b752f0 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 22c641408..7608959c2 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 9ea0c211f..bae450d26 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 a33fc633c..bcfdf14bf 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 a009be15d..a05984c4e 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 fcbbbf0d5..4030cf2f8 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 796e8b4ed..47c2d7ff2 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 @@ -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 4c1649ba1..57ee5d520 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 45b9539e0..ad1e0c93b 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) @@ -63,7 +65,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/GitAnnexShell.hs b/GitAnnexShell.hs index b5f6804e7..7c3893be3 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 @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011-2013 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - 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 () @@ -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 000000000..dc345dd0a --- /dev/null +++ b/Logs/NumCopies.hs @@ -0,0 +1,33 @@ +{- git-annex numcopies log + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - 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 000000000..03975df92 --- /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 <joey@kitenet.net> + - + - 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/RunCommand.hs b/RunCommand.hs new file mode 100644 index 000000000..937686d97 --- /dev/null +++ b/RunCommand.hs @@ -0,0 +1,70 @@ +{- git-annex running commands + - + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> + - + - 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 + +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. -} +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 :: CommandActionRunner +commandAction a = handle =<< tryAnnexIO go + where + go = do + Annex.Queue.flushWhenFull + callCommand a + handle (Right True) = return True + handle (Right False) = incerr + handle (Left err) = do + showErr err + showEndFail + incerr + 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, without catching errors. Useful if one command wants to run + - part of another command. -} +callCommand :: CommandActionRunner +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 @@ -4,7 +4,7 @@ - the values a user passes to a command, and prepare actions operating - on them. - - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - 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 ) -notSymlink :: FilePath -> IO Bool -notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f +seekActions :: Annex [CommandStart] -> Annex () +seekActions gen = do + as <- gen + mapM_ commandAction as -whenNotDirect :: CommandSeek -> CommandSeek -whenNotDirect a params = ifM isDirect ( return [] , a params ) +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 -whenDirect :: CommandSeek -> CommandSeek -whenDirect a params = ifM isDirect ( a params, return [] ) +notSymlink :: FilePath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f @@ -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/Command.hs b/Types/Command.hs index d012c6e25..ecde75cae 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 } diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index cda53f229..5cd09dbde 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/Types/StandardGroups.hs b/Types/StandardGroups.hs index 51788ec4e..c4c3ba9f3 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 d41fe5e6d..923fb1692 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,15 @@ 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. + * 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 <joeyh@debian.org> Sat, 18 Jan 2014 11:54:17 -0400 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 000000000..ef7579c46 --- /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. +"""]] 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 000000000..5b5b94a40 --- /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 +\"\"\"]] +"""]] 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 7f1dc9c0d..12a5e0c14 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/copies.mdwn b/doc/copies.mdwn index 93cbd8ea8..205d2d5b1 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/design/assistant/telehash.mdwn b/doc/design/assistant/telehash.mdwn index 9e1d6f613..777bce646 100644 --- a/doc/design/assistant/telehash.mdwn +++ b/doc/design/assistant/telehash.mdwn @@ -58,3 +58,33 @@ 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. 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. + +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. 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 000000000..e8d0dcfe8 --- /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. +"""]] diff --git a/doc/devblog/day_101__old_mistakes.mdwn b/doc/devblog/day_101__old_mistakes.mdwn new file mode 100644 index 000000000..4a37416dc --- /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. 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 000000000..8a1ecfdd2 --- /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. +"""]] diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index e8058720c..8a948d303 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. @@ -1006,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 @@ -1117,12 +1140,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 +1168,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 +1484,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/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 7f78da537..2c8bf4b71 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/doc/internals.mdwn b/doc/internals.mdwn index d95ab3f5e..1cf0cf505 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/preferred_content.mdwn b/doc/preferred_content.mdwn index 9c698c8ba..b18f46c33 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/tips/using_the_web_as_a_special_remote.mdwn b/doc/tips/using_the_web_as_a_special_remote.mdwn index 706ae2951..62ef58b69 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/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 877e9fdbf..cbd01181f 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 000000000..8aa736a04 --- /dev/null +++ b/doc/todo/preferred_content_numcopies_check.mdwn @@ -0,0 +1,84 @@ +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. **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. **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 + 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" **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 + +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]] 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 297047e06..fe32f7dd7 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]] diff --git a/doc/walkthrough/fsck:_verifying_your_data.mdwn b/doc/walkthrough/fsck:_verifying_your_data.mdwn index d036332fb..62e15b6fa 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 2d3c0cde0..ccd2d197f 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. diff --git a/git-annex.cabal b/git-annex.cabal index 9b4edf8b2..a7322e400 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) |