Merge branch 'master' of git://git-annex.branchable.com
This commit is contained in:
commit
48cdbf3bfd
116 changed files with 923 additions and 453 deletions
6
Annex.hs
6
Annex.hs
|
@ -94,7 +94,7 @@ data AnnexState = AnnexState
|
|||
, checkattrhandle :: Maybe CheckAttrHandle
|
||||
, checkignorehandle :: Maybe (Maybe CheckIgnoreHandle)
|
||||
, forcebackend :: Maybe String
|
||||
, forcenumcopies :: Maybe Int
|
||||
, globalnumcopies :: Maybe Int
|
||||
, limit :: Matcher (MatchInfo -> Annex Bool)
|
||||
, uuidmap :: Maybe UUIDMap
|
||||
, preferredcontentmap :: Maybe PreferredContentMap
|
||||
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -70,6 +70,7 @@ parseToken checkpresent checkpreferreddir groupmap t
|
|||
[ ("include", limitInclude)
|
||||
, ("exclude", limitExclude)
|
||||
, ("copies", limitCopies)
|
||||
, ("numcopiesneeded", limitNumCopiesNeeded)
|
||||
, ("inbackend", limitInBackend)
|
||||
, ("largerthan", limitSize (>))
|
||||
, ("smallerthan", limitSize (<))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
45
CmdLine.hs
45
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
|
||||
|
|
33
Command.hs
33
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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
56
Command/NumCopies.hs
Normal 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
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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:[])
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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:
|
||||
-
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
27
Limit.hs
27
Limit.hs
|
@ -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
13
Logs.hs
|
@ -11,7 +11,11 @@ import Common.Annex
|
|||
import Types.Key
|
||||
|
||||
{- There are several varieties of log file formats. -}
|
||||
data LogVariety = UUIDBasedLog | NewUUIDBasedLog | PresenceLog Key
|
||||
data LogVariety
|
||||
= UUIDBasedLog
|
||||
| NewUUIDBasedLog
|
||||
| PresenceLog Key
|
||||
| SingleValueLog
|
||||
deriving (Show)
|
||||
|
||||
{- Converts a path from the git-annex branch into one of the varieties
|
||||
|
@ -20,6 +24,7 @@ getLogVariety :: FilePath -> Maybe LogVariety
|
|||
getLogVariety f
|
||||
| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog
|
||||
| isRemoteStateLog f = Just NewUUIDBasedLog
|
||||
| f == numcopiesLog = Just SingleValueLog
|
||||
| otherwise = PresenceLog <$> firstJust (presenceLogs f)
|
||||
|
||||
{- All the uuid-based logs stored in the top of the git-annex branch. -}
|
||||
|
@ -43,6 +48,9 @@ presenceLogs f =
|
|||
uuidLog :: FilePath
|
||||
uuidLog = "uuid.log"
|
||||
|
||||
numcopiesLog :: FilePath
|
||||
numcopiesLog = "numcopies.log"
|
||||
|
||||
remoteLog :: FilePath
|
||||
remoteLog = "remote.log"
|
||||
|
||||
|
@ -118,6 +126,7 @@ prop_logs_sane dummykey = all id
|
|||
, expect isPresenceLog (getLogVariety $ locationLogFile dummykey)
|
||||
, expect isPresenceLog (getLogVariety $ urlLogFile dummykey)
|
||||
, expect isNewUUIDBasedLog (getLogVariety $ remoteStateLogFile dummykey)
|
||||
, expect isSingleValueLog (getLogVariety $ numcopiesLog)
|
||||
]
|
||||
where
|
||||
expect = maybe False
|
||||
|
@ -127,3 +136,5 @@ prop_logs_sane dummykey = all id
|
|||
isNewUUIDBasedLog _ = False
|
||||
isPresenceLog (PresenceLog k) = k == dummykey
|
||||
isPresenceLog _ = False
|
||||
isSingleValueLog SingleValueLog = True
|
||||
isSingleValueLog _ = False
|
||||
|
|
33
Logs/NumCopies.hs
Normal file
33
Logs/NumCopies.hs
Normal 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
65
Logs/SingleValue.hs
Normal 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
70
RunCommand.hs
Normal 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
82
Seek.hs
|
@ -4,7 +4,7 @@
|
|||
- the values a user passes to a command, and prepare actions operating
|
||||
- on them.
|
||||
-
|
||||
- Copyright 2010-2013 Joey Hess <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 [] )
|
||||
|
|
9
Test.hs
9
Test.hs
|
@ -292,6 +292,9 @@ test_drop_withremote :: TestEnv -> Assertion
|
|||
test_drop_withremote env = intmpclonerepo env $ do
|
||||
git_annex env "get" [annexedfile] @? "get failed"
|
||||
annexed_present annexedfile
|
||||
git_annex env "numcopies" ["2"] @? "numcopies config failed"
|
||||
not <$> git_annex env "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied"
|
||||
git_annex env "numcopies" ["1"] @? "numcopies config failed"
|
||||
git_annex env "drop" [annexedfile] @? "drop failed though origin has copy"
|
||||
annexed_notpresent annexedfile
|
||||
inmainrepo env $ annexed_present annexedfile
|
||||
|
@ -511,9 +514,9 @@ test_trust env = intmpclonerepo env $ do
|
|||
test_fsck_basic :: TestEnv -> Assertion
|
||||
test_fsck_basic env = intmpclonerepo env $ do
|
||||
git_annex env "fsck" [] @? "fsck failed"
|
||||
boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed"
|
||||
git_annex env "numcopies" ["2"] @? "numcopies config failed"
|
||||
fsck_should_fail env "numcopies unsatisfied"
|
||||
boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed"
|
||||
git_annex env "numcopies" ["1"] @? "numcopies config failed"
|
||||
corrupt annexedfile
|
||||
corrupt sha1annexedfile
|
||||
where
|
||||
|
@ -542,7 +545,7 @@ test_fsck_localuntrusted env = intmpclonerepo env $ do
|
|||
|
||||
test_fsck_remoteuntrusted :: TestEnv -> Assertion
|
||||
test_fsck_remoteuntrusted env = intmpclonerepo env $ do
|
||||
boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed"
|
||||
git_annex env "numcopies" ["2"] @? "numcopies config failed"
|
||||
git_annex env "get" [annexedfile] @? "get failed"
|
||||
git_annex env "get" [sha1annexedfile] @? "get failed"
|
||||
git_annex env "fsck" [] @? "fsck failed with numcopies=2 and 2 copies"
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
9
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
|
@ -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.
|
||||
"""]]
|
|
@ -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
|
||||
\"\"\"]]
|
||||
"""]]
|
|
@ -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
Loading…
Add table
Add a link
Reference in a new issue