Merge branch 'master' of git://git-annex.branchable.com

This commit is contained in:
Richard Hartmann 2014-01-21 00:58:15 +01:00
commit 48cdbf3bfd
116 changed files with 923 additions and 453 deletions

View file

@ -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.

View file

@ -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

View file

@ -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.
-
- A remote can be specified that is known to have the key. This can be
- used an an optimisation when eg, a key has just been uploaded to a
- remote.
-}
handleDrops :: Reason -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
handleDrops _ _ _ _ Nothing _ = noop
handleDrops reason rs fromhere key f knownpresentremote = do
locs <- loggedLocations key
handleDropsFrom locs rs reason fromhere key f knownpresentremote
{- The UUIDs are ones where the content is believed to be present.
- The UUIDs are ones where the content is believed to be present.
- The Remote list can include other remotes that do not have the content;
- only ones that match the UUIDs will be dropped from.
- If allowed to drop fromhere, that drop will be tried first.
-
- A remote can be specified that is known to have the key. This can be
- used an an optimisation when eg, a key has just been uploaded to a
- remote.
-
- In direct mode, all associated files are checked, and only if all
- of them are unwanted are they dropped.
-
- The runner is used to run commands, and so can be either callCommand
- or commandAction.
-}
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
handleDropsFrom _ _ _ _ _ Nothing _ = noop
handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote = do
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
handleDropsFrom _ _ _ _ _ Nothing _ _ = noop
handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runner = do
fs <- ifM isDirect
( do
l <- associatedFilesRelative key
@ -92,7 +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

View file

@ -70,6 +70,7 @@ parseToken checkpresent checkpreferreddir groupmap t
[ ("include", limitInclude)
, ("exclude", limitExclude)
, ("copies", limitCopies)
, ("numcopiesneeded", limitNumCopiesNeeded)
, ("inbackend", limitInBackend)
, ("largerthan", limitSize (>))
, ("smallerthan", limitSize (<))

View file

@ -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

View file

@ -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.

View file

@ -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

View file

@ -21,6 +21,7 @@ import Utility.DataUnits
import Git.Config
import Types.Distribution
import qualified Build.SysConfig
import Logs.NumCopies
import qualified Data.Text as T
@ -81,7 +82,7 @@ prefsAForm def = PrefsForm
getPrefs :: Annex PrefsForm
getPrefs = PrefsForm
<$> (T.pack . roughSize storageUnits False . annexDiskReserve <$> Annex.getGitConfig)
<*> (annexNumCopies <$> Annex.getGitConfig)
<*> (maybe deprecatedNumCopies return =<< getGlobalNumCopies)
<*> inAutoStartFile
<*> (annexAutoUpgrade <$> Annex.getGitConfig)
<*> (annexDebug <$> Annex.getGitConfig)
@ -89,7 +90,8 @@ getPrefs = PrefsForm
storePrefs :: PrefsForm -> Annex ()
storePrefs p = do
setConfig (annexConfig "diskreserve") (T.unpack $ diskReserve p)
setConfig (annexConfig "numcopies") (show $ numCopies p)
setGlobalNumCopies (numCopies p)
unsetConfig (annexConfig "numcopies") -- deprecated
setConfig (annexConfig "autoupgrade") (fromAutoUpgrade $ autoUpgrade p)
unlessM ((==) <$> pure (autoStart p) <*> inAutoStartFile) $ do
here <- fromRepo Git.repoPath

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 )

View file

@ -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.

View file

@ -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

View file

@ -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)

View file

@ -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."

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -70,16 +70,17 @@ fsckOptions =
, incrementalScheduleOption
] ++ keyOptions
seek :: [CommandSeek]
seek =
[ withField fromOption Remote.byNameWithUUID $ \from ->
withIncremental $ \i ->
withKeyOptions (startKey i) $
withFilesInGit $ whenAnnexed $ start from i
]
seek :: CommandSeek
seek ps = do
from <- getOptionField fromOption Remote.byNameWithUUID
i <- getIncremental
withKeyOptions
(startKey i)
(withFilesInGit $ whenAnnexed $ start from i)
ps
withIncremental :: (Incremental -> CommandSeek) -> CommandSeek
withIncremental = withValue $ do
getIncremental :: Annex Incremental
getIncremental = do
i <- maybe (return False) (checkschedule . parseDuration)
=<< Annex.getField (Option.name incrementalScheduleOption)
starti <- Annex.getFlag (Option.name startIncrementalOption)

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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) =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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."

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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.
-}

56
Command/NumCopies.hs Normal file
View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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:[])

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
sequence_ =<< handleget have
putrs <- catMaybes . snd . unzip <$> (sequence =<< handleput lack)
let results = getresults ++ putresults
if null results
then stop
else do
showStart "sync" f
next $ next $ return $ all id results
-- Using callCommand rather than commandAction for drops,
-- because a failure to drop does not mean the sync failed.
handleDropsFrom (putrs ++ locs) rs "unwanted" True k (Just f)
Nothing callCommand
where
run a = do
r <- a
showEndResult r
return r
wantget have = allM id
[ pure (not $ null have)
, not <$> inAnnex k
@ -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)

View file

@ -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

View file

@ -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:
-

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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. -}

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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"

View file

@ -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,

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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 ()

13
Logs.hs
View file

@ -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

33
Logs/NumCopies.hs Normal file
View file

@ -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

65
Logs/SingleValue.hs Normal file
View file

@ -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)

70
RunCommand.hs Normal file
View file

@ -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

82
Seek.hs
View file

@ -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 )
seekActions :: Annex [CommandStart] -> Annex ()
seekActions gen = do
as <- gen
mapM_ commandAction as
seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath]
seekHelper a params = do
ll <- inRepo $ \g ->
runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params
{- Show warnings only for files/directories that do not exist. -}
forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p ->
unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $
fileNotFound p
return $ concat ll
notSymlink :: FilePath -> IO Bool
notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
whenNotDirect :: CommandSeek -> CommandSeek
whenNotDirect a params = ifM isDirect ( return [] , a params )
whenDirect :: CommandSeek -> CommandSeek
whenDirect a params = ifM isDirect ( a params, return [] )

View file

@ -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"

View file

@ -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
}

View file

@ -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

View file

@ -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"

9
debian/changelog vendored
View file

@ -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

View file

@ -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.
"""]]

View file

@ -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
\"\"\"]]
"""]]

View file

@ -91,3 +91,5 @@ ExitFailure 1
# End of transcript or log.
"""]]
> [[fixed|done]] --[[Joey]]

Some files were not shown because too many files have changed in this diff Show more