add SeekInput (not yet used)
No behavior changes (hopefully), just adding SeekInput and plumbing it through to the JSON display code for later use. Over the course of 2 grueling days. withFilesNotInGit reimplemented in terms of seekHelper should be the only possible behavior change. It seems to test as behaving the same. Note that seekHelper dummies up the SeekInput in the case where segmentPaths' gives up on sorting the expanded paths because there are too many input paths. When SeekInput later gets exposed as a json field, that will result in it being a little bit wrong in the case where 100 or more paths are passed to a git-annex command. I think this is a subtle enough problem to not matter. If it does turn out to be a problem, fixing it would require splitting up the input parameters into groups of < 100, which would make git ls-files run perhaps more than is necessary. May want to revisit this, because that fix seems fairly low-impact.
This commit is contained in:
parent
a1accac084
commit
3a05d53761
88 changed files with 561 additions and 405 deletions
|
@ -47,8 +47,8 @@ type Reason = String
|
|||
- The runner is used to run CommandStart sequentially, it's typically
|
||||
- callCommandAction.
|
||||
-}
|
||||
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
|
||||
handleDropsFrom locs rs reason fromhere key afile preverified runner = do
|
||||
handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> SeekInput -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex ()
|
||||
handleDropsFrom locs rs reason fromhere key afile si preverified runner = do
|
||||
g <- Annex.gitRepo
|
||||
l <- map (`fromTopFilePath` g)
|
||||
<$> Database.Keys.getAssociatedFiles key
|
||||
|
@ -120,10 +120,10 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
|
|||
|
||||
dropl fs n = checkdrop fs n Nothing $ \numcopies ->
|
||||
stopUnless (inAnnex key) $
|
||||
Command.Drop.startLocal afile ai numcopies key preverified
|
||||
Command.Drop.startLocal afile ai si numcopies key preverified
|
||||
|
||||
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
|
||||
Command.Drop.startRemote afile ai numcopies key r
|
||||
Command.Drop.startRemote afile ai si numcopies key r
|
||||
|
||||
ai = mkActionItem (key, afile)
|
||||
|
||||
|
|
|
@ -364,7 +364,8 @@ importKeys remote importtreeconfig importcontent importablecontents = do
|
|||
[] -> do
|
||||
job <- liftIO $ newEmptyTMVarIO
|
||||
let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc)))
|
||||
let importaction = starting ("import " ++ Remote.name remote) ai $ do
|
||||
let si = SeekInput []
|
||||
let importaction = starting ("import " ++ Remote.name remote) ai si $ do
|
||||
when oldversion $
|
||||
showNote "old version"
|
||||
tryNonAsync (importordownload cidmap db i largematcher) >>= \case
|
||||
|
|
|
@ -16,6 +16,7 @@ import Annex.Drop (handleDropsFrom, Reason)
|
|||
import Logs.Location
|
||||
import CmdLine.Action
|
||||
import Types.NumCopies
|
||||
import Types.Command
|
||||
|
||||
{- Drop from local and/or remote when allowed by the preferred content and
|
||||
- numcopies settings. -}
|
||||
|
@ -23,4 +24,7 @@ handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> Assi
|
|||
handleDrops reason fromhere key f preverified = do
|
||||
syncrs <- syncDataRemotes <$> getDaemonStatus
|
||||
locs <- liftAnnex $ loggedLocations key
|
||||
liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction
|
||||
liftAnnex $ handleDropsFrom
|
||||
locs syncrs reason fromhere key f
|
||||
(SeekInput [])
|
||||
preverified callCommandAction
|
||||
|
|
|
@ -30,6 +30,7 @@ import Annex.WorkTree
|
|||
import Annex.Content
|
||||
import Annex.Wanted
|
||||
import CmdLine.Action
|
||||
import Types.Command
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Control.Concurrent
|
||||
|
@ -168,7 +169,7 @@ expensiveScan urlrenderer rs = batch <~> do
|
|||
|
||||
liftAnnex $ handleDropsFrom locs syncrs
|
||||
"expensive scan found too many copies of object"
|
||||
present key af [] callCommandAction
|
||||
present key af (SeekInput []) [] callCommandAction
|
||||
ts <- if present
|
||||
then liftAnnex . filterM (wantSend True (Just key) af . Remote.uuid . fst)
|
||||
=<< use syncDataRemotes (genTransfer Upload False)
|
||||
|
|
|
@ -1,3 +1,10 @@
|
|||
git-annex (8.20200909) UNRELEASED; urgency=medium
|
||||
|
||||
* --json output now includes a new field "input" which is the input
|
||||
(filename, url, etc) that caused that json to be output.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Mon, 14 Sep 2020 13:13:10 -0400
|
||||
|
||||
git-annex (8.20200908) upstream; urgency=medium
|
||||
|
||||
* Added httpalso special remote, which is useful for accessing
|
||||
|
|
|
@ -42,7 +42,7 @@ parseBatchOption = go
|
|||
-- In batch mode, one line at a time is read, parsed, and a reply output to
|
||||
-- stdout. In non batch mode, the command's parameters are parsed and
|
||||
-- a reply output for each.
|
||||
batchable :: (opts -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser
|
||||
batchable :: (opts -> SeekInput -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser
|
||||
batchable handler parser paramdesc = batchseeker <$> batchparser
|
||||
where
|
||||
batchparser = (,,)
|
||||
|
@ -51,12 +51,12 @@ batchable handler parser paramdesc = batchseeker <$> batchparser
|
|||
<*> cmdParams paramdesc
|
||||
|
||||
batchseeker (opts, NoBatch, params) =
|
||||
mapM_ (go NoBatch opts) params
|
||||
mapM_ (\p -> go NoBatch opts (SeekInput [p], p)) params
|
||||
batchseeker (opts, batchmode@(Batch fmt), _) =
|
||||
batchInput fmt (pure . Right) (go batchmode opts)
|
||||
|
||||
go batchmode opts p =
|
||||
unlessM (handler opts p) $
|
||||
go batchmode opts (si, p) =
|
||||
unlessM (handler opts si p) $
|
||||
batchBadInput batchmode
|
||||
|
||||
-- bad input is indicated by an empty line in batch mode. In non batch
|
||||
|
@ -72,12 +72,12 @@ batchBadInput (Batch _) = liftIO $ putStrLn ""
|
|||
-- be converted to relative. Normally, filename parameters are passed
|
||||
-- through git ls-files, which makes them relative, but batch mode does
|
||||
-- not use that, and absolute worktree files are likely to cause breakage.
|
||||
batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex ()
|
||||
batchInput :: BatchFormat -> (String -> Annex (Either String v)) -> ((SeekInput, v) -> Annex ()) -> Annex ()
|
||||
batchInput fmt parser a = go =<< batchLines fmt
|
||||
where
|
||||
go [] = return ()
|
||||
go (l:rest) = do
|
||||
either parseerr a =<< parser l
|
||||
either parseerr (\v -> a (SeekInput [l], v)) =<< parser l
|
||||
go rest
|
||||
parseerr s = giveup $ "Batch input parse failure: " ++ s
|
||||
|
||||
|
@ -107,28 +107,29 @@ batchCommandAction a = maybe (batchBadInput (Batch BatchLine)) (const noop)
|
|||
-- Absolute filepaths are converted to relative.
|
||||
--
|
||||
-- File matching options are not checked.
|
||||
batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex ()
|
||||
batchStart :: BatchFormat -> (SeekInput -> FilePath -> CommandStart) -> Annex ()
|
||||
batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $
|
||||
batchCommandAction . a
|
||||
batchCommandAction . uncurry a
|
||||
|
||||
-- Like batchStart, but checks the file matching options
|
||||
-- and skips non-matching files.
|
||||
batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex ()
|
||||
batchFilesMatching :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex ()
|
||||
batchFilesMatching fmt a = do
|
||||
matcher <- getMatcher
|
||||
batchStart fmt $ \f ->
|
||||
batchStart fmt $ \si f ->
|
||||
let f' = toRawFilePath f
|
||||
in ifM (matcher $ MatchingFile $ FileInfo f' f')
|
||||
( a f'
|
||||
( a (si, f')
|
||||
, return Nothing
|
||||
)
|
||||
|
||||
batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex ()
|
||||
batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $
|
||||
whenAnnexed $ \f k -> case checkContentPresent seeker of
|
||||
Just v -> do
|
||||
present <- inAnnex k
|
||||
if present == v
|
||||
then startAction seeker f k
|
||||
else return Nothing
|
||||
Nothing -> startAction seeker f k
|
||||
batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ \(si, bf) ->
|
||||
flip whenAnnexed bf $ \f k ->
|
||||
case checkContentPresent seeker of
|
||||
Just v -> do
|
||||
present <- inAnnex k
|
||||
if present == v
|
||||
then startAction seeker si f k
|
||||
else return Nothing
|
||||
Nothing -> startAction seeker si f k
|
||||
|
|
|
@ -50,7 +50,7 @@ import Control.Concurrent.Async
|
|||
import System.Posix.Types
|
||||
|
||||
data AnnexedFileSeeker = AnnexedFileSeeker
|
||||
{ startAction :: RawFilePath -> Key -> CommandStart
|
||||
{ startAction :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
, checkContentPresent :: Maybe Bool
|
||||
, usesLocationLog :: Bool
|
||||
}
|
||||
|
@ -74,25 +74,18 @@ withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.ge
|
|||
case fs of
|
||||
[f] -> do
|
||||
void $ liftIO $ cleanup
|
||||
getfiles (f:c) ps
|
||||
getfiles ((SeekInput [p], f):c) ps
|
||||
[] -> do
|
||||
void $ liftIO $ cleanup
|
||||
getfiles c ps
|
||||
_ -> giveup needforce
|
||||
withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop
|
||||
|
||||
withFilesNotInGit :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesNotInGit a (WorkTreeItems l) = go =<< seek
|
||||
where
|
||||
seek = do
|
||||
force <- Annex.getState Annex.force
|
||||
g <- gitRepo
|
||||
liftIO $ Git.Command.leaveZombie
|
||||
<$> LsFiles.notInRepo [] force l' g
|
||||
go fs = seekFiltered a $
|
||||
return $ concat $ segmentPaths id l' fs
|
||||
l' = map toRawFilePath l
|
||||
withFilesNotInGit _ NoWorkTreeItems = noop
|
||||
withFilesNotInGit :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesNotInGit ww a l = do
|
||||
force <- Annex.getState Annex.force
|
||||
seekFiltered a $
|
||||
seekHelper id ww (const $ LsFiles.notInRepo [] force) l
|
||||
|
||||
withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withPathContents a params = do
|
||||
|
@ -119,23 +112,24 @@ withWords a params = a params
|
|||
withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withStrings a params = sequence_ $ map a params
|
||||
|
||||
withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withPairs a params = sequence_ $ map a $ pairs [] params
|
||||
withPairs :: ((SeekInput, (String, String)) -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withPairs a params = sequence_ $
|
||||
map (\p@(x,y) -> a (SeekInput [x,y], p)) (pairs [] params)
|
||||
where
|
||||
pairs c [] = reverse c
|
||||
pairs c (x:y:xs) = pairs ((x,y):c) xs
|
||||
pairs _ _ = giveup "expected pairs"
|
||||
|
||||
withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesToBeCommitted a l = seekFiltered a $
|
||||
seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
|
||||
|
||||
{- unlocked pointer files that are staged, and whose content has not been
|
||||
- modified-}
|
||||
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles
|
||||
where
|
||||
unlockedfiles = filterM isUnmodifiedUnlocked
|
||||
unlockedfiles = filterM (isUnmodifiedUnlocked . snd)
|
||||
=<< seekHelper id ww (const LsFiles.typeChangedStaged) l
|
||||
|
||||
isUnmodifiedUnlocked :: RawFilePath -> Annex Bool
|
||||
|
@ -144,12 +138,12 @@ isUnmodifiedUnlocked f = catKeyFile f >>= \case
|
|||
Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k
|
||||
|
||||
{- Finds files that may be modified. -}
|
||||
withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
|
||||
withFilesMaybeModified ww a params = seekFiltered a $
|
||||
seekHelper id ww LsFiles.modified params
|
||||
|
||||
withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withKeys a l = sequence_ $ map (a . parse) l
|
||||
withKeys :: ((SeekInput, Key) -> CommandSeek) -> CmdParams -> CommandSeek
|
||||
withKeys a ls = sequence_ $ map (\l -> a (SeekInput [l], parse l)) ls
|
||||
where
|
||||
parse p = fromMaybe (giveup "bad key") $ deserializeKey p
|
||||
|
||||
|
@ -170,7 +164,7 @@ withKeyOptions
|
|||
:: Maybe KeyOptions
|
||||
-> Bool
|
||||
-> AnnexedFileSeeker
|
||||
-> ((Key, ActionItem) -> CommandSeek)
|
||||
-> ((SeekInput, Key, ActionItem) -> CommandSeek)
|
||||
-> (WorkTreeItems -> CommandSeek)
|
||||
-> WorkTreeItems
|
||||
-> CommandSeek
|
||||
|
@ -178,7 +172,7 @@ withKeyOptions ko auto seeker keyaction = withKeyOptions' ko auto mkkeyaction
|
|||
where
|
||||
mkkeyaction = do
|
||||
matcher <- Limit.getMatcher
|
||||
return $ \v@(k, ai) -> checkseeker k $
|
||||
return $ \v@(_si, k, ai) -> checkseeker k $
|
||||
let i = case ai of
|
||||
ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
|
||||
MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)
|
||||
|
@ -194,7 +188,7 @@ withKeyOptions ko auto seeker keyaction = withKeyOptions' ko auto mkkeyaction
|
|||
withKeyOptions'
|
||||
:: Maybe KeyOptions
|
||||
-> Bool
|
||||
-> Annex ((Key, ActionItem) -> Annex ())
|
||||
-> Annex ((SeekInput, Key, ActionItem) -> Annex ())
|
||||
-> (WorkTreeItems -> CommandSeek)
|
||||
-> WorkTreeItems
|
||||
-> CommandSeek
|
||||
|
@ -245,7 +239,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
|
|||
Nothing -> return ()
|
||||
Just ((k, f), content) -> do
|
||||
maybe noop (Annex.BranchState.setCache f) content
|
||||
keyaction (k, mkActionItem k)
|
||||
keyaction (SeekInput [], k, mkActionItem k)
|
||||
go reader
|
||||
catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go
|
||||
liftIO $ void cleanup
|
||||
|
@ -253,7 +247,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
|
|||
runkeyaction getks = do
|
||||
keyaction <- mkkeyaction
|
||||
ks <- getks
|
||||
forM_ ks $ \k -> keyaction (k, mkActionItem k)
|
||||
forM_ ks $ \k -> keyaction (SeekInput [], k, mkActionItem k)
|
||||
|
||||
runbranchkeys bs = do
|
||||
keyaction <- mkkeyaction
|
||||
|
@ -263,7 +257,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
|
|||
Nothing -> noop
|
||||
Just k ->
|
||||
let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k)
|
||||
in keyaction (k, bfp)
|
||||
in keyaction (SeekInput [], k, bfp)
|
||||
unlessM (liftIO cleanup) $
|
||||
error ("git ls-tree " ++ Git.fromRef b ++ " failed")
|
||||
|
||||
|
@ -272,21 +266,21 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
|
|||
rs <- remoteList
|
||||
ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs
|
||||
forM_ ts $ \(t, i) ->
|
||||
keyaction (transferKey t, mkActionItem (t, i))
|
||||
keyaction (SeekInput [], transferKey t, mkActionItem (t, i))
|
||||
|
||||
seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex ()
|
||||
seekFiltered :: ((SeekInput, RawFilePath) -> CommandSeek) -> Annex [(SeekInput, RawFilePath)] -> Annex ()
|
||||
seekFiltered a fs = do
|
||||
matcher <- Limit.getMatcher
|
||||
sequence_ =<< (map (process matcher) <$> fs)
|
||||
where
|
||||
process matcher f =
|
||||
whenM (matcher $ MatchingFile $ FileInfo f f) $ a f
|
||||
process matcher v@(_si, f) =
|
||||
whenM (matcher $ MatchingFile $ FileInfo f f) (a v)
|
||||
|
||||
-- This is significantly faster than using lookupKey after seekFiltered,
|
||||
-- because of the way data is streamed through git cat-file.
|
||||
--
|
||||
-- It can also precache location logs using the same efficient streaming.
|
||||
seekFilteredKeys :: AnnexedFileSeeker -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex ()
|
||||
seekFilteredKeys :: AnnexedFileSeeker -> Annex [(SeekInput, (RawFilePath, Git.Sha, FileMode))] -> Annex ()
|
||||
seekFilteredKeys seeker listfs = do
|
||||
g <- Annex.gitRepo
|
||||
matcher <- Limit.getMatcher
|
||||
|
@ -317,38 +311,38 @@ seekFilteredKeys seeker listfs = do
|
|||
Nothing -> cont
|
||||
|
||||
finisher oreader = liftIO oreader >>= \case
|
||||
Just (f, content) -> do
|
||||
Just ((si, f), content) -> do
|
||||
case parseLinkTargetOrPointerLazy =<< content of
|
||||
Just k -> checkpresence k $
|
||||
commandAction $
|
||||
startAction seeker f k
|
||||
startAction seeker si f k
|
||||
Nothing -> noop
|
||||
finisher oreader
|
||||
Nothing -> return ()
|
||||
|
||||
precachefinisher lreader = liftIO lreader >>= \case
|
||||
Just ((logf, f, k), logcontent) -> do
|
||||
Just ((logf, (si, f), k), logcontent) -> do
|
||||
maybe noop (Annex.BranchState.setCache logf) logcontent
|
||||
commandAction $ startAction seeker f k
|
||||
commandAction $ startAction seeker si f k
|
||||
precachefinisher lreader
|
||||
Nothing -> return ()
|
||||
|
||||
precacher config oreader lfeeder lcloser = liftIO oreader >>= \case
|
||||
Just (f, content) -> do
|
||||
Just ((si, f), content) -> do
|
||||
case parseLinkTargetOrPointerLazy =<< content of
|
||||
Just k -> checkpresence k $
|
||||
let logf = locationLogFile config k
|
||||
ref = Git.Ref.branchFileRef Annex.Branch.fullname logf
|
||||
in liftIO $ lfeeder ((logf, f, k), ref)
|
||||
in liftIO $ lfeeder ((logf, (si, f), k), ref)
|
||||
Nothing -> noop
|
||||
precacher config oreader lfeeder lcloser
|
||||
Nothing -> liftIO $ void lcloser
|
||||
|
||||
feedmatches matcher ofeeder f sha =
|
||||
feedmatches matcher ofeeder si f sha =
|
||||
whenM (matcher $ MatchingFile $ FileInfo f f) $
|
||||
liftIO $ ofeeder (f, sha)
|
||||
liftIO $ ofeeder ((si, f), sha)
|
||||
|
||||
process matcher ofeeder mdfeeder mdcloser seenpointer ((f, sha, mode):rest) =
|
||||
process matcher ofeeder mdfeeder mdcloser seenpointer ((si, (f, sha, mode)):rest) =
|
||||
case Git.toTreeItemType mode of
|
||||
Just Git.TreeSymlink -> do
|
||||
whenM (exists f) $
|
||||
|
@ -358,8 +352,8 @@ seekFilteredKeys seeker listfs = do
|
|||
-- slower, but preserves the requested
|
||||
-- file order.
|
||||
if seenpointer
|
||||
then liftIO $ mdfeeder (f, sha)
|
||||
else feedmatches matcher ofeeder f sha
|
||||
then liftIO $ mdfeeder ((si, f), sha)
|
||||
else feedmatches matcher ofeeder si f sha
|
||||
process matcher ofeeder mdfeeder mdcloser seenpointer rest
|
||||
Just Git.TreeSubmodule ->
|
||||
process matcher ofeeder mdfeeder mdcloser seenpointer rest
|
||||
|
@ -368,7 +362,7 @@ seekFilteredKeys seeker listfs = do
|
|||
-- large files by first looking up the size.
|
||||
Just _ -> do
|
||||
whenM (exists f) $
|
||||
liftIO $ mdfeeder (f, sha)
|
||||
liftIO $ mdfeeder ((si, f), sha)
|
||||
process matcher ofeeder mdfeeder mdcloser True rest
|
||||
Nothing ->
|
||||
process matcher ofeeder mdfeeder mdcloser seenpointer rest
|
||||
|
@ -379,19 +373,24 @@ seekFilteredKeys seeker listfs = do
|
|||
exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p)
|
||||
|
||||
mdprocess matcher mdreader ofeeder ocloser = liftIO mdreader >>= \case
|
||||
Just (f, Just (sha, size, _type))
|
||||
Just ((si, f), Just (sha, size, _type))
|
||||
| size < maxPointerSz -> do
|
||||
feedmatches matcher ofeeder f sha
|
||||
feedmatches matcher ofeeder si f sha
|
||||
mdprocess matcher mdreader ofeeder ocloser
|
||||
Just _ -> mdprocess matcher mdreader ofeeder ocloser
|
||||
Nothing -> liftIO $ void ocloser
|
||||
|
||||
seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [a]
|
||||
seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [(SeekInput, a)]
|
||||
seekHelper c ww a (WorkTreeItems l) = do
|
||||
os <- seekOptions ww
|
||||
inRepo $ \g ->
|
||||
concat . concat <$> forM (segmentXargsOrdered l)
|
||||
(runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
|
||||
(runSegmentPaths' mk c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath)
|
||||
where
|
||||
mk (Just i) f = (SeekInput [fromRawFilePath i], f)
|
||||
-- This is not accurate, but it only happens when there are a
|
||||
-- great many input WorkTreeItems.
|
||||
mk Nothing f = (SeekInput [fromRawFilePath (c f)], f)
|
||||
seekHelper _ _ _ NoWorkTreeItems = return []
|
||||
|
||||
data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems
|
||||
|
|
10
Command.hs
10
Command.hs
|
@ -74,13 +74,15 @@ withGlobalOptions :: [[GlobalOption]] -> Command -> Command
|
|||
withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }
|
||||
|
||||
{- For start stage to indicate what will be done. -}
|
||||
starting:: MkActionItem t => String -> t -> CommandPerform -> CommandStart
|
||||
starting msg t a = next (StartMessage msg (mkActionItem t), a)
|
||||
starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart
|
||||
starting msg ai si a = next
|
||||
(StartMessage msg (mkActionItem ai) si, a)
|
||||
|
||||
{- Use when noMessages was used but the command is going to output
|
||||
- usual messages after all. -}
|
||||
startingUsualMessages :: MkActionItem t => String -> t -> CommandPerform -> CommandStart
|
||||
startingUsualMessages msg t a = next (StartUsualMessages msg (mkActionItem t), a)
|
||||
startingUsualMessages :: MkActionItem t => String -> t -> SeekInput -> CommandPerform -> CommandStart
|
||||
startingUsualMessages msg t si a = next
|
||||
(StartUsualMessages msg (mkActionItem t) si, a)
|
||||
|
||||
{- When no message should be displayed at start/end, but messages can still
|
||||
- be displayed when using eg includeCommandAction. -}
|
||||
|
|
|
@ -64,18 +64,18 @@ seek o = startConcurrency commandStages $ do
|
|||
largematcher <- largeFilesMatcher
|
||||
addunlockedmatcher <- addUnlockedMatcher
|
||||
annexdotfiles <- getGitConfigVal annexDotFiles
|
||||
let gofile file = case largeFilesOverride o of
|
||||
let gofile (si, file) = case largeFilesOverride o of
|
||||
Nothing ->
|
||||
let file' = fromRawFilePath file
|
||||
in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force))
|
||||
( start file addunlockedmatcher
|
||||
( start si file addunlockedmatcher
|
||||
, ifM (annexAddSmallFiles <$> Annex.getGitConfig)
|
||||
( startSmall file
|
||||
( startSmall si file
|
||||
, stop
|
||||
)
|
||||
)
|
||||
Just True -> start file addunlockedmatcher
|
||||
Just False -> startSmallOverridden file
|
||||
Just True -> start si file addunlockedmatcher
|
||||
Just False -> startSmallOverridden si file
|
||||
case batchOption o of
|
||||
Batch fmt
|
||||
| updateOnly o ->
|
||||
|
@ -90,13 +90,13 @@ seek o = startConcurrency commandStages $ do
|
|||
l <- workTreeItems ww (addThese o)
|
||||
let go a = a ww (commandAction . gofile) l
|
||||
unless (updateOnly o) $
|
||||
go (const withFilesNotInGit)
|
||||
go withFilesNotInGit
|
||||
go withFilesMaybeModified
|
||||
go withUnmodifiedUnlockedPointers
|
||||
|
||||
{- Pass file off to git-add. -}
|
||||
startSmall :: RawFilePath -> CommandStart
|
||||
startSmall file = starting "add" (ActionItemWorkTreeFile file) $
|
||||
startSmall :: SeekInput -> RawFilePath -> CommandStart
|
||||
startSmall si file = starting "add" (ActionItemWorkTreeFile file) si $
|
||||
next $ addSmall file
|
||||
|
||||
addSmall :: RawFilePath -> Annex Bool
|
||||
|
@ -104,8 +104,8 @@ addSmall file = do
|
|||
showNote "non-large file; adding content to git repository"
|
||||
addFile file
|
||||
|
||||
startSmallOverridden :: RawFilePath -> CommandStart
|
||||
startSmallOverridden file = starting "add" (ActionItemWorkTreeFile file) $
|
||||
startSmallOverridden :: SeekInput -> RawFilePath -> CommandStart
|
||||
startSmallOverridden si file = starting "add" (ActionItemWorkTreeFile file) si $
|
||||
next $ addSmallOverridden file
|
||||
|
||||
addSmallOverridden :: RawFilePath -> Annex Bool
|
||||
|
@ -133,8 +133,8 @@ addFile file = do
|
|||
Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file]
|
||||
return True
|
||||
|
||||
start :: RawFilePath -> AddUnlockedMatcher -> CommandStart
|
||||
start file addunlockedmatcher = do
|
||||
start :: SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart
|
||||
start si file addunlockedmatcher = do
|
||||
mk <- liftIO $ isPointerFile file
|
||||
maybe go fixuppointer mk
|
||||
where
|
||||
|
@ -144,7 +144,7 @@ start file addunlockedmatcher = do
|
|||
Just s
|
||||
| not (isRegularFile s) && not (isSymbolicLink s) -> stop
|
||||
| otherwise ->
|
||||
starting "add" (ActionItemWorkTreeFile file) $
|
||||
starting "add" (ActionItemWorkTreeFile file) si $
|
||||
if isSymbolicLink s
|
||||
then next $ addFile file
|
||||
else perform file addunlockedmatcher
|
||||
|
@ -152,13 +152,13 @@ start file addunlockedmatcher = do
|
|||
liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case
|
||||
Just s | isSymbolicLink s -> fixuplink key
|
||||
_ -> add
|
||||
fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do
|
||||
fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do
|
||||
-- the annexed symlink is present but not yet added to git
|
||||
liftIO $ removeFile (fromRawFilePath file)
|
||||
addLink (fromRawFilePath file) key Nothing
|
||||
next $
|
||||
cleanup key =<< inAnnex key
|
||||
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do
|
||||
fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do
|
||||
-- the pointer file is present, but not yet added to git
|
||||
Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)
|
||||
next $ addFile file
|
||||
|
|
|
@ -104,12 +104,13 @@ parseDownloadOptions withfileoptions = DownloadOptions
|
|||
seek :: AddUrlOptions -> CommandSeek
|
||||
seek o = startConcurrency commandStages $ do
|
||||
addunlockedmatcher <- addUnlockedMatcher
|
||||
let go (o', u) = do
|
||||
let go (si, (o', u)) = do
|
||||
r <- Remote.claimingUrl u
|
||||
if Remote.uuid r == webUUID || rawOption (downloadOptions o')
|
||||
then void $ commandAction $ startWeb addunlockedmatcher o' u
|
||||
else checkUrl addunlockedmatcher r o' u
|
||||
forM_ (addUrls o) (\u -> go (o, u))
|
||||
then void $ commandAction $
|
||||
startWeb addunlockedmatcher o' si u
|
||||
else checkUrl addunlockedmatcher r o' si u
|
||||
forM_ (addUrls o) (\u -> go (SeekInput [u], (o, u)))
|
||||
case batchOption o of
|
||||
Batch fmt -> batchInput fmt (pure . parseBatchInput o) go
|
||||
NoBatch -> noop
|
||||
|
@ -123,8 +124,8 @@ parseBatchInput o s
|
|||
else Right (o { downloadOptions = (downloadOptions o) { fileOption = Just f } }, u)
|
||||
| otherwise = Right (o, s)
|
||||
|
||||
checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> Annex ()
|
||||
checkUrl addunlockedmatcher r o u = do
|
||||
checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> URLString -> Annex ()
|
||||
checkUrl addunlockedmatcher r o si u = do
|
||||
pathmax <- liftIO $ fileNameLengthLimit "."
|
||||
let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o))
|
||||
go deffile =<< maybe
|
||||
|
@ -133,35 +134,35 @@ checkUrl addunlockedmatcher r o u = do
|
|||
(Remote.checkUrl r)
|
||||
where
|
||||
|
||||
go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do
|
||||
go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do
|
||||
warning (show e)
|
||||
next $ return False
|
||||
go deffile (Right (UrlContents sz mf)) = do
|
||||
f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf
|
||||
let f' = adjustFile o (fromMaybe f (fileOption (downloadOptions o)))
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o f' u sz
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o si f' u sz
|
||||
go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of
|
||||
Nothing ->
|
||||
forM_ l $ \(u', sz, f) -> do
|
||||
f' <- sanitizeOrPreserveFilePath o f
|
||||
let f'' = adjustFile o (deffile </> f')
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o f'' u' sz
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o si f'' u' sz
|
||||
Just f -> case l of
|
||||
[] -> noop
|
||||
((u',sz,_):[]) -> do
|
||||
let f' = adjustFile o f
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o f' u' sz
|
||||
void $ commandAction $ startRemote addunlockedmatcher r o si f' u' sz
|
||||
_ -> giveup $ unwords
|
||||
[ "That url contains multiple files according to the"
|
||||
, Remote.name r
|
||||
, " remote; cannot add it to a single file."
|
||||
]
|
||||
|
||||
startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart
|
||||
startRemote addunlockedmatcher r o file uri sz = do
|
||||
startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart
|
||||
startRemote addunlockedmatcher r o si file uri sz = do
|
||||
pathmax <- liftIO $ fileNameLengthLimit "."
|
||||
let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file
|
||||
startingAddUrl uri o $ do
|
||||
startingAddUrl si uri o $ do
|
||||
showNote $ "from " ++ Remote.name r
|
||||
showDestinationFile file'
|
||||
performRemote addunlockedmatcher r o uri file' sz
|
||||
|
@ -199,12 +200,12 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do
|
|||
loguri = setDownloader uri OtherDownloader
|
||||
af = AssociatedFile (Just (toRawFilePath file))
|
||||
|
||||
startWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> CommandStart
|
||||
startWeb addunlockedmatcher o urlstring = go $ fromMaybe bad $ parseURI urlstring
|
||||
startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart
|
||||
startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring
|
||||
where
|
||||
bad = fromMaybe (giveup $ "bad url " ++ urlstring) $
|
||||
Url.parseURIRelaxed $ urlstring
|
||||
go url = startingAddUrl urlstring o $
|
||||
go url = startingAddUrl si urlstring o $
|
||||
if relaxedOption (downloadOptions o)
|
||||
then go' url Url.assumeUrlExists
|
||||
else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case
|
||||
|
@ -353,8 +354,8 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
{- The destination file is not known at start time unless the user provided
|
||||
- a filename. It's not displayed then for output consistency,
|
||||
- but is added to the json when available. -}
|
||||
startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart
|
||||
startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do
|
||||
startingAddUrl :: SeekInput -> URLString -> AddUrlOptions -> CommandPerform -> CommandStart
|
||||
startingAddUrl si url o p = starting "addurl" (ActionItemOther (Just url)) si $ do
|
||||
case fileOption (downloadOptions o) of
|
||||
Nothing -> noop
|
||||
Just file -> maybeShowJSON $ JSONChunk [("file", file)]
|
||||
|
|
|
@ -51,5 +51,5 @@ seek = commandAction . start
|
|||
start :: Adjustment -> CommandStart
|
||||
start adj = do
|
||||
checkVersionSupported
|
||||
starting "adjust" (ActionItemOther Nothing) $
|
||||
starting "adjust" (ActionItemOther Nothing) (SeekInput []) $
|
||||
next $ enterAdjustedBranch adj
|
||||
|
|
|
@ -19,8 +19,8 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
|
|||
(paramRepeating paramFile)
|
||||
(batchable run (pure ()))
|
||||
|
||||
run :: () -> String -> Annex Bool
|
||||
run _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case
|
||||
run :: () -> SeekInput -> String -> Annex Bool
|
||||
run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case
|
||||
Right (k, _) -> do
|
||||
liftIO $ putStrLn $ serializeKey k
|
||||
return True
|
||||
|
|
|
@ -39,7 +39,8 @@ seek o = case batchOption o of
|
|||
(rn:[]) -> toRemote rn >>= \r -> return (flip check (Just r))
|
||||
[] -> return (flip check Nothing)
|
||||
_ -> wrongnumparams
|
||||
batchInput fmt (pure . Right) $ checker >=> batchResult
|
||||
batchInput fmt (pure . Right) $
|
||||
checker . snd >=> batchResult
|
||||
where
|
||||
wrongnumparams = giveup "Wrong number of parameters"
|
||||
|
||||
|
|
|
@ -20,7 +20,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withNothing (commandAction start)
|
||||
|
||||
start :: CommandStart
|
||||
start = starting "commit" (ActionItemOther (Just "git-annex")) $ do
|
||||
start = starting "commit" (ActionItemOther (Just "git-annex")) (SeekInput []) $ do
|
||||
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
||||
_ <- runhook <=< inRepo $ Git.hookPath "annex-content"
|
||||
next $ return True
|
||||
|
|
|
@ -55,24 +55,32 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
|
|||
|
||||
seek :: Action -> CommandSeek
|
||||
seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $
|
||||
startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do
|
||||
startingUsualMessages (decodeBS' name) ai si $ do
|
||||
setGlobalConfig ck val
|
||||
when (needLocalUpdate ck) $
|
||||
setConfig ck (fromConfigValue val)
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther (Just (fromConfigValue val))
|
||||
si = SeekInput [decodeBS' name]
|
||||
seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $
|
||||
startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do
|
||||
startingUsualMessages (decodeBS' name) ai si $ do
|
||||
unsetGlobalConfig ck
|
||||
when (needLocalUpdate ck) $
|
||||
unsetConfig ck
|
||||
next $ return True
|
||||
seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $
|
||||
startingCustomOutput (ActionItemOther Nothing) $ do
|
||||
where
|
||||
ai = ActionItemOther (Just "unset")
|
||||
si = SeekInput [decodeBS' name]
|
||||
seek (GetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $
|
||||
startingCustomOutput ai $ do
|
||||
getGlobalConfig ck >>= \case
|
||||
Just (ConfigValue v) -> liftIO $ S8.putStrLn v
|
||||
Just NoConfigValue -> return ()
|
||||
Nothing -> return ()
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther Nothing
|
||||
|
||||
checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a
|
||||
checkIsGlobalConfig ck@(ConfigKey name) a
|
||||
|
|
|
@ -20,8 +20,8 @@ cmd = noCommit $ noMessages $
|
|||
(paramRepeating paramKey)
|
||||
(batchable run (pure ()))
|
||||
|
||||
run :: () -> String -> Annex Bool
|
||||
run _ p = do
|
||||
run :: () -> SeekInput -> String -> Annex Bool
|
||||
run _ _ p = do
|
||||
let k = fromMaybe (giveup "bad key") $ deserializeKey p
|
||||
maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True)
|
||||
=<< inAnnex' (pure True) Nothing check k
|
||||
|
|
|
@ -67,9 +67,9 @@ seek o = startConcurrency commandStages $ do
|
|||
{- A copy is just a move that does not delete the source file.
|
||||
- However, auto mode avoids unnecessary copies, and avoids getting or
|
||||
- sending non-preferred content. -}
|
||||
start :: CopyOptions -> RawFilePath -> Key -> CommandStart
|
||||
start o file key = stopUnless shouldCopy $
|
||||
Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key
|
||||
start :: CopyOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o si file key = stopUnless shouldCopy $
|
||||
Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key
|
||||
where
|
||||
shouldCopy
|
||||
| autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<)
|
||||
|
|
|
@ -32,11 +32,11 @@ seek (DeadRemotes rs) = trustCommand "dead" DeadTrusted rs
|
|||
seek (DeadKeys ks) = commandActions $ map startKey ks
|
||||
|
||||
startKey :: Key -> CommandStart
|
||||
startKey key = starting "dead" (mkActionItem key) $
|
||||
startKey key = starting "dead" (mkActionItem key) (SeekInput []) $
|
||||
keyLocations key >>= \case
|
||||
[] -> performKey key
|
||||
_ -> giveup "This key is still known to be present in some locations; not marking as dead."
|
||||
|
||||
|
||||
performKey :: Key -> CommandPerform
|
||||
performKey key = do
|
||||
setDead key
|
||||
|
|
|
@ -23,8 +23,11 @@ seek = withWords (commandAction . start)
|
|||
start :: [String] -> CommandStart
|
||||
start (name:description) | not (null description) = do
|
||||
u <- Remote.nameToUUID name
|
||||
starting "describe" (ActionItemOther (Just name)) $
|
||||
starting "describe" ai si $
|
||||
perform u $ unwords description
|
||||
where
|
||||
ai = ActionItemOther (Just name)
|
||||
si = SeekInput [name]
|
||||
start _ = giveup "Specify a repository and a description."
|
||||
|
||||
perform :: UUID -> String -> CommandPerform
|
||||
|
|
|
@ -76,35 +76,35 @@ seek o = startConcurrency commandStages $ do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: DropOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart
|
||||
start o from file key = start' o from key afile ai
|
||||
start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o from si file key = start' o from key afile ai si
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
ai = mkActionItem (key, afile)
|
||||
|
||||
start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
|
||||
start' o from key afile ai =
|
||||
start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart
|
||||
start' o from key afile ai si =
|
||||
checkDropAuto (autoMode o) from afile key $ \numcopies ->
|
||||
stopUnless want $
|
||||
case from of
|
||||
Nothing -> startLocal afile ai numcopies key []
|
||||
Just remote -> startRemote afile ai numcopies key remote
|
||||
Nothing -> startLocal afile ai si numcopies key []
|
||||
Just remote -> startRemote afile ai si numcopies key remote
|
||||
where
|
||||
want
|
||||
| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile
|
||||
| otherwise = return True
|
||||
|
||||
startKeys :: DropOptions -> Maybe Remote -> (Key, ActionItem) -> CommandStart
|
||||
startKeys o from (key, ai) = start' o from key (AssociatedFile Nothing) ai
|
||||
startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si
|
||||
|
||||
startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
|
||||
startLocal afile ai numcopies key preverified =
|
||||
starting "drop" (OnlyActionOn key ai) $
|
||||
startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
|
||||
startLocal afile ai si numcopies key preverified =
|
||||
starting "drop" (OnlyActionOn key ai) si $
|
||||
performLocal key afile numcopies preverified
|
||||
|
||||
startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart
|
||||
startRemote afile ai numcopies key remote =
|
||||
starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) $
|
||||
startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> Remote -> CommandStart
|
||||
startRemote afile ai si numcopies key remote =
|
||||
starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $
|
||||
performRemote key afile numcopies remote
|
||||
|
||||
performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
|
||||
|
|
|
@ -41,8 +41,8 @@ seek o = do
|
|||
where
|
||||
parsekey = maybe (Left "bad key") Right . deserializeKey
|
||||
|
||||
start :: Key -> CommandStart
|
||||
start key = starting "dropkey" (mkActionItem key) $
|
||||
start :: (SeekInput, Key) -> CommandStart
|
||||
start (si, key) = starting "dropkey" (mkActionItem key) si $
|
||||
perform key
|
||||
|
||||
perform :: Key -> CommandPerform
|
||||
|
|
|
@ -58,13 +58,16 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes
|
|||
-- the remote uuid.
|
||||
startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart
|
||||
startNormalRemote name restparams r
|
||||
| null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do
|
||||
| null restparams = starting "enableremote" ai si $ do
|
||||
setRemoteIgnore r False
|
||||
r' <- Remote.Git.configRead False r
|
||||
u <- getRepoUUID r'
|
||||
next $ return $ u /= NoUUID
|
||||
| otherwise = giveup $
|
||||
"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams
|
||||
where
|
||||
ai = ActionItemOther (Just name)
|
||||
si = SeekInput [name]
|
||||
|
||||
startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID)) -> CommandStart
|
||||
startSpecialRemote name config Nothing = do
|
||||
|
@ -76,13 +79,16 @@ startSpecialRemote name config Nothing = do
|
|||
Just (u, fromMaybe M.empty (M.lookup u confm), Nothing)
|
||||
_ -> unknownNameError "Unknown remote name."
|
||||
startSpecialRemote name config (Just (u, c, mcu)) =
|
||||
starting "enableremote" (ActionItemOther (Just name)) $ do
|
||||
starting "enableremote" ai si $ do
|
||||
let fullconfig = config `M.union` c
|
||||
t <- either giveup return (SpecialRemote.findType fullconfig)
|
||||
gc <- maybe (liftIO dummyRemoteGitConfig)
|
||||
(return . Remote.gitconfig)
|
||||
=<< Remote.byUUID u
|
||||
performSpecialRemote t u c fullconfig gc mcu
|
||||
where
|
||||
ai = ActionItemOther (Just name)
|
||||
si = SeekInput [name]
|
||||
|
||||
performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform
|
||||
performSpecialRemote t u oldc c gc mcu = do
|
||||
|
|
|
@ -47,12 +47,14 @@ start os = do
|
|||
start _os = do
|
||||
#endif
|
||||
#ifndef mingw32_HOST_OS
|
||||
let ai = ActionItemOther Nothing
|
||||
let si = SeekInput []
|
||||
curruserid <- liftIO getEffectiveUserID
|
||||
if curruserid == 0
|
||||
then case readish =<< headMaybe os of
|
||||
Nothing -> giveup "Need user-id parameter."
|
||||
Just userid -> go userid
|
||||
else starting "enable-tor" (ActionItemOther Nothing) $ do
|
||||
else starting "enable-tor" ai si $ do
|
||||
gitannex <- liftIO programPath
|
||||
let ps = [Param (cmdname cmd), Param (show curruserid)]
|
||||
sucommand <- liftIO $ mkSuCommand gitannex ps
|
||||
|
|
|
@ -19,8 +19,8 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
|
|||
(paramRepeating paramKey)
|
||||
(batchable run (optional parseFormatOption))
|
||||
|
||||
run :: Maybe Utility.Format.Format -> String -> Annex Bool
|
||||
run format p = do
|
||||
run :: Maybe Utility.Format.Format -> SeekInput -> String -> Annex Bool
|
||||
run format _ p = do
|
||||
let k = fromMaybe (giveup "bad key") $ deserializeKey p
|
||||
showFormatted format (serializeKey' k) (keyVars k)
|
||||
return True
|
||||
|
|
|
@ -60,13 +60,13 @@ start :: Expire -> Bool -> Log Activity -> UUIDDescMap -> UUID -> CommandStart
|
|||
start (Expire expire) noact actlog descs u =
|
||||
case lastact of
|
||||
Just ent | notexpired ent -> checktrust (== DeadTrusted) $
|
||||
starting "unexpire" (ActionItemOther (Just desc)) $ do
|
||||
starting "unexpire" ai si $ do
|
||||
showNote =<< whenactive
|
||||
unless noact $
|
||||
trustSet u SemiTrusted
|
||||
next $ return True
|
||||
_ -> checktrust (/= DeadTrusted) $
|
||||
starting "expire" (ActionItemOther (Just desc)) $ do
|
||||
starting "expire" ai si $ do
|
||||
showNote =<< whenactive
|
||||
unless noact $
|
||||
trustSet u DeadTrusted
|
||||
|
@ -79,6 +79,8 @@ start (Expire expire) noact actlog descs u =
|
|||
return $ "last active: " ++ fromDuration d ++ " ago"
|
||||
_ -> return "no activity"
|
||||
desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs))
|
||||
ai = ActionItemOther (Just desc)
|
||||
si = SeekInput []
|
||||
notexpired ent = case ent of
|
||||
Unknown -> False
|
||||
VectorClock c -> case lookupexpire of
|
||||
|
|
|
@ -258,7 +258,7 @@ startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled ->
|
|||
startExport r db cvar allfilledvar ti = do
|
||||
ek <- exportKey (Git.LsTree.sha ti)
|
||||
stopUnless (notrecordedpresent ek) $
|
||||
starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $
|
||||
starting ("export " ++ name r) ai si $
|
||||
ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc))
|
||||
( next $ cleanupExport r db ek loc False
|
||||
, do
|
||||
|
@ -269,6 +269,8 @@ startExport r db cvar allfilledvar ti = do
|
|||
loc = mkExportLocation f
|
||||
f = getTopFilePath (Git.LsTree.file ti)
|
||||
af = AssociatedFile (Just f)
|
||||
ai = ActionItemOther (Just (fromRawFilePath f))
|
||||
si = SeekInput []
|
||||
notrecordedpresent ek = (||)
|
||||
<$> liftIO (notElem loc <$> getExportedLocation db (asKey ek))
|
||||
-- If content was removed from the remote, the export db
|
||||
|
@ -321,18 +323,23 @@ startUnexport r db f shas = do
|
|||
eks <- forM (filter (`notElem` nullShas) shas) exportKey
|
||||
if null eks
|
||||
then stop
|
||||
else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
|
||||
else starting ("unexport " ++ name r) ai si $
|
||||
performUnexport r db eks loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
ai = ActionItemOther (Just (fromRawFilePath f'))
|
||||
si = SeekInput []
|
||||
|
||||
startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $
|
||||
performUnexport r db [ek] loc
|
||||
startUnexport' r db f ek =
|
||||
starting ("unexport " ++ name r) ai si $
|
||||
performUnexport r db [ek] loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
ai = ActionItemOther (Just (fromRawFilePath f'))
|
||||
si = SeekInput []
|
||||
|
||||
-- Unlike a usual drop from a repository, this does not check that
|
||||
-- numcopies is satisfied before removing the content. Typically an export
|
||||
|
@ -373,30 +380,36 @@ startRecoverIncomplete r db sha oldf
|
|||
| otherwise = do
|
||||
ek <- exportKey sha
|
||||
let loc = exportTempName ek
|
||||
starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))) $ do
|
||||
let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))
|
||||
let si = SeekInput []
|
||||
starting ("unexport " ++ name r) ai si $ do
|
||||
liftIO $ removeExportedLocation db (asKey ek) oldloc
|
||||
performUnexport r db [ek] loc
|
||||
where
|
||||
oldloc = mkExportLocation $ getTopFilePath oldf
|
||||
|
||||
startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart
|
||||
startMoveToTempName r db f ek = starting ("rename " ++ name r)
|
||||
(ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc))
|
||||
(performRename r db ek loc tmploc)
|
||||
startMoveToTempName r db f ek =
|
||||
starting ("rename " ++ name r) ai si $
|
||||
performRename r db ek loc tmploc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
tmploc = exportTempName ek
|
||||
ai = ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)
|
||||
si = SeekInput []
|
||||
|
||||
startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart
|
||||
startMoveFromTempName r db ek f = do
|
||||
let tmploc = exportTempName ek
|
||||
let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))
|
||||
stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $
|
||||
starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $
|
||||
starting ("rename " ++ name r) ai si $
|
||||
performRename r db ek tmploc loc
|
||||
where
|
||||
loc = mkExportLocation f'
|
||||
f' = getTopFilePath f
|
||||
si = SeekInput []
|
||||
|
||||
performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform
|
||||
performRename r db ek src dest =
|
||||
|
|
|
@ -73,14 +73,14 @@ seek o = do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: FindOptions -> RawFilePath -> Key -> CommandStart
|
||||
start o file key = startingCustomOutput key $ do
|
||||
start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o _ file key = startingCustomOutput key $ do
|
||||
showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key
|
||||
next $ return True
|
||||
|
||||
startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
|
||||
startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =
|
||||
start o (getTopFilePath topf) key
|
||||
startKeys :: FindOptions -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKeys o (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) =
|
||||
start o si (getTopFilePath topf) key
|
||||
startKeys _ _ = stop
|
||||
|
||||
showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()
|
||||
|
|
|
@ -43,8 +43,8 @@ seek ps = unlessM crippledFileSystem $
|
|||
|
||||
data FixWhat = FixSymlinks | FixAll
|
||||
|
||||
start :: FixWhat -> RawFilePath -> Key -> CommandStart
|
||||
start fixwhat file key = do
|
||||
start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start fixwhat si file key = do
|
||||
currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file
|
||||
wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key
|
||||
case currlink of
|
||||
|
@ -56,7 +56,7 @@ start fixwhat file key = do
|
|||
FixAll -> fixthin
|
||||
FixSymlinks -> stop
|
||||
where
|
||||
fixby = starting "fix" (mkActionItem (key, file))
|
||||
fixby = starting "fix" (mkActionItem (key, file)) si
|
||||
fixthin = do
|
||||
obj <- calcRepo (gitAnnexLocation key)
|
||||
stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do
|
||||
|
|
|
@ -33,13 +33,16 @@ seek :: ForgetOptions -> CommandSeek
|
|||
seek = commandAction . start
|
||||
|
||||
start :: ForgetOptions -> CommandStart
|
||||
start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do
|
||||
start o = starting "forget" ai si $ do
|
||||
c <- liftIO currentVectorClock
|
||||
let basets = addTransition c ForgetGitHistory noTransitions
|
||||
let ts = if dropDead o
|
||||
then addTransition c ForgetDeadRemotes basets
|
||||
else basets
|
||||
perform ts =<< Annex.getState Annex.force
|
||||
where
|
||||
ai = ActionItemOther (Just "git-annex")
|
||||
si = SeekInput []
|
||||
|
||||
perform :: Transitions -> Bool -> CommandPerform
|
||||
perform ts True = do
|
||||
|
|
|
@ -45,27 +45,30 @@ seek o = case (batchOption o, keyFilePairs o) of
|
|||
withPairs (commandAction . start force) ps
|
||||
|
||||
seekBatch :: BatchFormat -> CommandSeek
|
||||
seekBatch fmt = batchInput fmt parse commandAction
|
||||
seekBatch fmt = batchInput fmt parse (commandAction . go)
|
||||
where
|
||||
parse s = do
|
||||
let (keyname, file) = separate (== ' ') s
|
||||
if not (null keyname) && not (null file)
|
||||
then do
|
||||
file' <- liftIO $ relPathCwdToFile file
|
||||
return $ Right $ go file' (keyOpt keyname)
|
||||
return $ Right (file', keyOpt keyname)
|
||||
else return $
|
||||
Left "Expected pairs of key and filename"
|
||||
go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $
|
||||
perform key file
|
||||
go (si, (file, key)) =
|
||||
let ai = mkActionItem (key, toRawFilePath file)
|
||||
in starting "fromkey" ai si $
|
||||
perform key file
|
||||
|
||||
start :: Bool -> (String, FilePath) -> CommandStart
|
||||
start force (keyname, file) = do
|
||||
start :: Bool -> (SeekInput, (String, FilePath)) -> CommandStart
|
||||
start force (si, (keyname, file)) = do
|
||||
let key = keyOpt keyname
|
||||
unless force $ do
|
||||
inbackend <- inAnnex key
|
||||
unless inbackend $ giveup $
|
||||
"key ("++ keyname ++") is not present in backend (use --force to override this sanity check)"
|
||||
starting "fromkey" (mkActionItem (key, toRawFilePath file)) $
|
||||
let ai = mkActionItem (key, toRawFilePath file)
|
||||
starting "fromkey" ai si $
|
||||
perform key file
|
||||
|
||||
-- From user input to a Key.
|
||||
|
|
|
@ -111,8 +111,8 @@ checkDeadRepo u =
|
|||
whenM ((==) DeadTrusted <$> lookupTrust u) $
|
||||
earlyWarning "Warning: Fscking a repository that is currently marked as dead."
|
||||
|
||||
start :: Maybe Remote -> Incremental -> RawFilePath -> Key -> CommandStart
|
||||
start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \case
|
||||
start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case
|
||||
Nothing -> stop
|
||||
Just backend -> do
|
||||
numcopies <- getFileNumCopies (fromRawFilePath file)
|
||||
|
@ -120,7 +120,7 @@ start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \cas
|
|||
Nothing -> go $ perform key file backend numcopies
|
||||
Just r -> go $ performRemote key afile backend numcopies r
|
||||
where
|
||||
go = runFsck inc (mkActionItem (key, afile)) key
|
||||
go = runFsck inc si (mkActionItem (key, afile)) key
|
||||
afile = AssociatedFile (Just file)
|
||||
|
||||
perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool
|
||||
|
@ -197,11 +197,11 @@ performRemote key afile backend numcopies remote =
|
|||
Just a -> isRight <$> tryNonAsync (a key afile tmp)
|
||||
Nothing -> return False
|
||||
|
||||
startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart
|
||||
startKey from inc (key, ai) numcopies =
|
||||
startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart
|
||||
startKey from inc (si, key, ai) numcopies =
|
||||
Backend.maybeLookupBackendVariety (fromKey keyVariety key) >>= \case
|
||||
Nothing -> stop
|
||||
Just backend -> runFsck inc ai key $
|
||||
Just backend -> runFsck inc si ai key $
|
||||
case from of
|
||||
Nothing -> performKey key backend numcopies
|
||||
Just r -> performRemote key (AssociatedFile Nothing) backend numcopies r
|
||||
|
@ -555,9 +555,9 @@ badContentRemote remote localcopy key = do
|
|||
(False, Right ()) -> "dropped from " ++ Remote.name remote
|
||||
(_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e
|
||||
|
||||
runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart
|
||||
runFsck inc ai key a = stopUnless (needFsck inc key) $
|
||||
starting "fsck" (OnlyActionOn key ai) $ do
|
||||
runFsck :: Incremental -> SeekInput -> ActionItem -> Key -> Annex Bool -> CommandStart
|
||||
runFsck inc si ai key a = stopUnless (needFsck inc key) $
|
||||
starting "fsck" (OnlyActionOn key ai) si $ do
|
||||
ok <- a
|
||||
when ok $
|
||||
recordFsckTime inc key
|
||||
|
|
|
@ -22,7 +22,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withStrings (commandAction . start)
|
||||
|
||||
start :: String -> CommandStart
|
||||
start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do
|
||||
start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) (SeekInput [gcryptid]) $ do
|
||||
u <- getUUID
|
||||
when (u /= NoUUID) $
|
||||
giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!"
|
||||
|
|
|
@ -54,8 +54,8 @@ seek o = startConcurrency downloadStages $ do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart
|
||||
start o from file key = start' expensivecheck from key afile ai
|
||||
start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o from si file key = start' expensivecheck from key afile ai si
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
ai = mkActionItem (key, afile)
|
||||
|
@ -64,12 +64,12 @@ start o from file key = start' expensivecheck from key afile ai
|
|||
<||> wantGet False (Just key) afile
|
||||
| otherwise = return True
|
||||
|
||||
startKeys :: Maybe Remote -> (Key, ActionItem) -> CommandStart
|
||||
startKeys from (key, ai) = checkFailedTransferDirection ai Download $
|
||||
start' (return True) from key (AssociatedFile Nothing) ai
|
||||
startKeys :: Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKeys from (si, key, ai) = checkFailedTransferDirection ai Download $
|
||||
start' (return True) from key (AssociatedFile Nothing) ai si
|
||||
|
||||
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
|
||||
start' expensivecheck from key afile ai =
|
||||
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart
|
||||
start' expensivecheck from key afile ai si =
|
||||
stopUnless expensivecheck $
|
||||
case from of
|
||||
Nothing -> go $ perform key afile
|
||||
|
@ -77,7 +77,7 @@ start' expensivecheck from key afile ai =
|
|||
stopUnless (Command.Move.fromOk src key) $
|
||||
go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile
|
||||
where
|
||||
go = starting "get" (OnlyActionOn key ai)
|
||||
go = starting "get" (OnlyActionOn key ai) si
|
||||
|
||||
perform :: Key -> AssociatedFile -> CommandPerform
|
||||
perform key afile = stopUnless (getKey key afile) $
|
||||
|
|
|
@ -22,10 +22,13 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start (name:g:[]) = do
|
||||
start ps@(name:g:[]) = do
|
||||
u <- Remote.nameToUUID name
|
||||
startingUsualMessages "group" (ActionItemOther (Just name)) $
|
||||
startingUsualMessages "group" ai si $
|
||||
setGroup u (toGroup g)
|
||||
where
|
||||
ai = ActionItemOther (Just name)
|
||||
si = SeekInput ps
|
||||
start (name:[]) = do
|
||||
u <- Remote.nameToUUID name
|
||||
startingCustomOutput (ActionItemOther Nothing) $ do
|
||||
|
|
|
@ -24,6 +24,9 @@ seek = withWords (commandAction . start)
|
|||
start :: [String] -> CommandStart
|
||||
start (g:[]) = startingCustomOutput (ActionItemOther Nothing) $
|
||||
performGet groupPreferredContentMapRaw (toGroup g)
|
||||
start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $
|
||||
start ps@(g:expr:[]) = startingUsualMessages "groupwanted" ai si $
|
||||
performSet groupPreferredContentSet expr (toGroup g)
|
||||
where
|
||||
ai = ActionItemOther (Just g)
|
||||
si = SeekInput ps
|
||||
start _ = giveup "Specify a group."
|
||||
|
|
|
@ -125,11 +125,13 @@ seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do
|
|||
startLocal :: AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart
|
||||
startLocal addunlockedmatcher largematcher mode (srcfile, destfile) =
|
||||
ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile)
|
||||
( starting "import" (ActionItemWorkTreeFile destfile')
|
||||
pickaction
|
||||
( starting "import" ai si pickaction
|
||||
, stop
|
||||
)
|
||||
where
|
||||
ai = ActionItemWorkTreeFile destfile'
|
||||
si = SeekInput []
|
||||
|
||||
destfile' = toRawFilePath destfile
|
||||
|
||||
deletedup k = do
|
||||
|
@ -302,7 +304,7 @@ seekRemote remote branch msubdir importcontent = do
|
|||
fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb)
|
||||
|
||||
listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart
|
||||
listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $
|
||||
listContents remote tvar = starting "list" ai si $
|
||||
listImportableContents remote >>= \case
|
||||
Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote
|
||||
Just importable -> do
|
||||
|
@ -312,14 +314,18 @@ listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name r
|
|||
next $ do
|
||||
liftIO $ atomically $ writeTVar tvar (Just importable')
|
||||
return True
|
||||
where
|
||||
ai = ActionItemOther (Just (Remote.name remote))
|
||||
si = SeekInput []
|
||||
|
||||
commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart
|
||||
commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =
|
||||
starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do
|
||||
starting "update" ai si $ do
|
||||
importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable
|
||||
next $ updateremotetrackingbranch importcommit
|
||||
|
||||
where
|
||||
ai = ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)
|
||||
si = SeekInput []
|
||||
-- Update the tracking branch. Done even when there
|
||||
-- is nothing new to import, to make sure it exists.
|
||||
updateremotetrackingbranch importcommit =
|
||||
|
|
|
@ -20,8 +20,8 @@ cmd = noCommit $
|
|||
seek :: CmdParams -> CommandSeek
|
||||
seek = withKeys (commandAction . start)
|
||||
|
||||
start :: Key -> CommandStart
|
||||
start key = inAnnexSafe key >>= dispatch
|
||||
start :: (SeekInput, Key) -> CommandStart
|
||||
start (_, key) = inAnnexSafe key >>= dispatch
|
||||
where
|
||||
dispatch (Just True) = stop
|
||||
dispatch (Just False) = exit 1
|
||||
|
|
|
@ -125,7 +125,7 @@ start o [] = do
|
|||
globalInfo o
|
||||
stop
|
||||
start o ps = do
|
||||
mapM_ (itemInfo o) ps
|
||||
mapM_ (\p -> itemInfo o (SeekInput [p], p)) ps
|
||||
stop
|
||||
|
||||
globalInfo :: InfoOptions -> Annex ()
|
||||
|
@ -139,8 +139,8 @@ globalInfo o = do
|
|||
evalStateT (mapM_ showStat stats) (emptyStatInfo o)
|
||||
return True
|
||||
|
||||
itemInfo :: InfoOptions -> String -> Annex ()
|
||||
itemInfo o p = ifM (isdir p)
|
||||
itemInfo :: InfoOptions -> (SeekInput, String) -> Annex ()
|
||||
itemInfo o (_, p) = ifM (isdir p)
|
||||
( dirInfo o p
|
||||
, do
|
||||
disallowMatchingOptions
|
||||
|
|
|
@ -53,10 +53,14 @@ seek = commandAction . start
|
|||
|
||||
start :: InitOptions -> CommandStart
|
||||
start os
|
||||
| autoEnableOnly os = starting "init" (ActionItemOther (Just "autoenable")) $
|
||||
performAutoEnableOnly
|
||||
| otherwise = starting "init" (ActionItemOther (Just $ initDesc os)) $
|
||||
perform os
|
||||
| autoEnableOnly os =
|
||||
starting "init" (ActionItemOther (Just "autoenable")) si $
|
||||
performAutoEnableOnly
|
||||
| otherwise =
|
||||
starting "init" (ActionItemOther (Just $ initDesc os)) si $
|
||||
perform os
|
||||
where
|
||||
si = SeekInput []
|
||||
|
||||
perform :: InitOptions -> CommandPerform
|
||||
perform os = do
|
||||
|
|
|
@ -62,25 +62,26 @@ start _ [] = giveup "Specify a name for the remote."
|
|||
start o (name:ws) = ifM (isJust <$> findExisting name)
|
||||
( giveup $ "There is already a special remote named \"" ++ name ++
|
||||
"\". (Use enableremote to enable an existing special remote.)"
|
||||
, do
|
||||
ifM (isJust <$> Remote.byNameOnly name)
|
||||
( giveup $ "There is already a remote named \"" ++ name ++ "\""
|
||||
, do
|
||||
sameasuuid <- maybe
|
||||
(pure Nothing)
|
||||
(Just . Sameas <$$> getParsed)
|
||||
(sameas o)
|
||||
c <- newConfig name sameasuuid
|
||||
(Logs.Remote.keyValToConfig Proposed ws)
|
||||
<$> readRemoteLog
|
||||
t <- either giveup return (findType c)
|
||||
if whatElse o
|
||||
then startingCustomOutput (ActionItemOther Nothing) $
|
||||
describeOtherParamsFor c t
|
||||
else starting "initremote" (ActionItemOther (Just name)) $
|
||||
perform t name c o
|
||||
)
|
||||
, ifM (isJust <$> Remote.byNameOnly name)
|
||||
( giveup $ "There is already a remote named \"" ++ name ++ "\""
|
||||
, do
|
||||
sameasuuid <- maybe
|
||||
(pure Nothing)
|
||||
(Just . Sameas <$$> getParsed)
|
||||
(sameas o)
|
||||
c <- newConfig name sameasuuid
|
||||
(Logs.Remote.keyValToConfig Proposed ws)
|
||||
<$> readRemoteLog
|
||||
t <- either giveup return (findType c)
|
||||
if whatElse o
|
||||
then startingCustomOutput (ActionItemOther Nothing) $
|
||||
describeOtherParamsFor c t
|
||||
else starting "initremote" (ActionItemOther (Just name)) si $
|
||||
perform t name c o
|
||||
)
|
||||
)
|
||||
where
|
||||
si = SeekInput [name]
|
||||
|
||||
perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform
|
||||
perform t name c o = do
|
||||
|
|
|
@ -48,8 +48,8 @@ seek o = do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: S.Set Key -> RawFilePath -> Key -> CommandStart
|
||||
start s _file k
|
||||
start :: S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start s _si _file k
|
||||
| S.member k s = start' k
|
||||
| otherwise = stop
|
||||
|
||||
|
|
|
@ -77,8 +77,8 @@ getList o
|
|||
printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
|
||||
printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l
|
||||
|
||||
start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart
|
||||
start l file key = do
|
||||
start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start l si file key = do
|
||||
ls <- S.fromList <$> keyLocations key
|
||||
liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
|
||||
stop
|
||||
|
|
|
@ -37,10 +37,10 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
|
|||
, usesLocationLog = False
|
||||
}
|
||||
|
||||
start :: RawFilePath -> Key -> CommandStart
|
||||
start file key = ifM (isJust <$> isAnnexLink file)
|
||||
start :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start si file key = ifM (isJust <$> isAnnexLink file)
|
||||
( stop
|
||||
, starting "lock" (mkActionItem (key, file)) $
|
||||
, starting "lock" (mkActionItem (key, file)) si $
|
||||
go =<< liftIO (isPointerFile file)
|
||||
)
|
||||
where
|
||||
|
|
|
@ -100,8 +100,8 @@ seek o = do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart
|
||||
start o outputter file key = do
|
||||
start :: LogOptions -> (FilePath -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o outputter _ file key = do
|
||||
(changes, cleanup) <- getKeyLog key (passthruOptions o)
|
||||
showLogIncremental (outputter (fromRawFilePath file)) changes
|
||||
void $ liftIO cleanup
|
||||
|
|
|
@ -18,8 +18,8 @@ cmd = notBareRepo $ noCommit $ noMessages $
|
|||
(paramRepeating paramFile)
|
||||
(batchable run (pure ()))
|
||||
|
||||
run :: () -> String -> Annex Bool
|
||||
run _ file = seekSingleGitFile file >>= \case
|
||||
run :: () -> SeekInput -> String -> Annex Bool
|
||||
run _ _ file = seekSingleGitFile file >>= \case
|
||||
Nothing -> return False
|
||||
Just file' -> catKeyFile file' >>= \case
|
||||
Just k -> do
|
||||
|
|
|
@ -29,17 +29,23 @@ seek bs = do
|
|||
forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS')
|
||||
|
||||
mergeAnnexBranch :: CommandStart
|
||||
mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do
|
||||
mergeAnnexBranch = starting "merge" ai si $ do
|
||||
_ <- Annex.Branch.update
|
||||
-- commit explicitly, in case no remote branches were merged
|
||||
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther (Just "git-annex")
|
||||
si = SeekInput []
|
||||
|
||||
mergeSyncedBranch :: CommandStart
|
||||
mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch
|
||||
|
||||
mergeBranch :: Git.Ref -> CommandStart
|
||||
mergeBranch r = starting "merge" (ActionItemOther (Just (Git.fromRef r))) $ do
|
||||
mergeBranch r = starting "merge" ai si $ do
|
||||
currbranch <- getCurrentBranch
|
||||
let o = def { notOnlyAnnexOption = True }
|
||||
next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r
|
||||
where
|
||||
ai = ActionItemOther (Just (Git.fromRef r))
|
||||
si = SeekInput []
|
||||
|
|
|
@ -93,24 +93,24 @@ seek o = case batchOption o of
|
|||
Batch fmt -> withMessageState $ \s -> case outputType s of
|
||||
JSONOutput _ -> ifM limited
|
||||
( giveup "combining --batch with file matching options is not currently supported"
|
||||
, batchInput fmt parseJSONInput $
|
||||
commandAction . startBatch
|
||||
, batchInput fmt parseJSONInput
|
||||
(commandAction . startBatch)
|
||||
)
|
||||
_ -> giveup "--batch is currently only supported in --json mode"
|
||||
|
||||
start :: VectorClock -> MetaDataOptions -> RawFilePath -> Key -> CommandStart
|
||||
start c o file k = startKeys c o (k, mkActionItem (k, afile))
|
||||
start :: VectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start c o si file k = startKeys c o (si, k, mkActionItem (k, afile))
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
|
||||
startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart
|
||||
startKeys c o (k, ai) = case getSet o of
|
||||
startKeys :: VectorClock -> MetaDataOptions -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKeys c o (si, k, ai) = case getSet o of
|
||||
Get f -> startingCustomOutput k $ do
|
||||
l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k
|
||||
liftIO $ forM_ l $
|
||||
B8.putStrLn . fromMetaValue
|
||||
next $ return True
|
||||
_ -> starting "metadata" ai $
|
||||
_ -> starting "metadata" ai si $
|
||||
perform c o k
|
||||
|
||||
perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform
|
||||
|
@ -170,8 +170,8 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of
|
|||
(Nothing, Nothing) -> return $
|
||||
Left "JSON input is missing either file or key"
|
||||
|
||||
startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart
|
||||
startBatch (i, (MetaData m)) = case i of
|
||||
startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart
|
||||
startBatch (si, (i, (MetaData m))) = case i of
|
||||
Left f -> do
|
||||
mk <- lookupKey f
|
||||
case mk of
|
||||
|
@ -179,7 +179,7 @@ startBatch (i, (MetaData m)) = case i of
|
|||
Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f
|
||||
Right k -> go k (mkActionItem k)
|
||||
where
|
||||
go k ai = starting "metadata" ai $ do
|
||||
go k ai = starting "metadata" ai si $ do
|
||||
let o = MetaDataOptions
|
||||
{ forFiles = []
|
||||
, getSet = if MetaData m == emptyMetaData
|
||||
|
|
|
@ -35,8 +35,8 @@ seek = withFilesInGitAnnex ww seeker <=< workTreeItems ww
|
|||
, usesLocationLog = False
|
||||
}
|
||||
|
||||
start :: RawFilePath -> Key -> CommandStart
|
||||
start file key = do
|
||||
start :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start si file key = do
|
||||
forced <- Annex.getState Annex.force
|
||||
v <- Backend.getBackend (fromRawFilePath file) key
|
||||
case v of
|
||||
|
@ -46,7 +46,7 @@ start file key = do
|
|||
newbackend <- maybe defaultBackend return
|
||||
=<< chooseBackend (fromRawFilePath file)
|
||||
if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
|
||||
then starting "migrate" (mkActionItem (key, file)) $
|
||||
then starting "migrate" (mkActionItem (key, file)) si $
|
||||
perform file key oldbackend newbackend
|
||||
else stop
|
||||
|
||||
|
|
|
@ -57,19 +57,19 @@ seek o = startConcurrency stages $
|
|||
, usesLocationLog = True
|
||||
}
|
||||
|
||||
start :: MirrorOptions -> RawFilePath -> Key -> CommandStart
|
||||
start o file k = startKey o afile (k, ai)
|
||||
start :: MirrorOptions -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o si file k = startKey o afile (si, k, ai)
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
ai = mkActionItem (k, afile)
|
||||
|
||||
startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart
|
||||
startKey o afile (key, ai) = case fromToOptions o of
|
||||
startKey :: MirrorOptions -> AssociatedFile -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKey o afile (si, key, ai) = case fromToOptions o of
|
||||
ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
|
||||
( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r
|
||||
( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r
|
||||
, do
|
||||
numcopies <- getnumcopies
|
||||
Command.Drop.startRemote afile ai numcopies key =<< getParsed r
|
||||
Command.Drop.startRemote afile ai si numcopies key =<< getParsed r
|
||||
)
|
||||
FromRemote r -> checkFailedTransferDirection ai Download $ do
|
||||
haskey <- flip Remote.hasKey key =<< getParsed r
|
||||
|
@ -77,12 +77,12 @@ startKey o afile (key, ai) = case fromToOptions o of
|
|||
Left _ -> stop
|
||||
Right True -> ifM (inAnnex key)
|
||||
( stop
|
||||
, Command.Get.start' (return True) Nothing key afile ai
|
||||
, Command.Get.start' (return True) Nothing key afile ai si
|
||||
)
|
||||
Right False -> ifM (inAnnex key)
|
||||
( do
|
||||
numcopies <- getnumcopies
|
||||
Command.Drop.startLocal afile ai numcopies key []
|
||||
Command.Drop.startLocal afile ai si numcopies key []
|
||||
, stop
|
||||
)
|
||||
where
|
||||
|
|
|
@ -76,42 +76,42 @@ seek o = startConcurrency stages $ do
|
|||
Left ToHere -> downloadStages
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart
|
||||
start fromto removewhen f k = start' fromto removewhen afile k ai
|
||||
start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start fromto removewhen si f k = start' fromto removewhen afile si k ai
|
||||
where
|
||||
afile = AssociatedFile (Just f)
|
||||
ai = mkActionItem (k, afile)
|
||||
|
||||
startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart
|
||||
startKey fromto removewhen =
|
||||
uncurry $ start' fromto removewhen (AssociatedFile Nothing)
|
||||
startKey :: FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKey fromto removewhen (si, k, ai) =
|
||||
start' fromto removewhen (AssociatedFile Nothing) si k ai
|
||||
|
||||
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
||||
start' fromto removewhen afile key ai =
|
||||
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart
|
||||
start' fromto removewhen afile si key ai =
|
||||
case fromto of
|
||||
Right (FromRemote src) ->
|
||||
checkFailedTransferDirection ai Download $
|
||||
fromStart removewhen afile key ai =<< getParsed src
|
||||
fromStart removewhen afile key ai si =<< getParsed src
|
||||
Right (ToRemote dest) ->
|
||||
checkFailedTransferDirection ai Upload $
|
||||
toStart removewhen afile key ai =<< getParsed dest
|
||||
toStart removewhen afile key ai si =<< getParsed dest
|
||||
Left ToHere ->
|
||||
checkFailedTransferDirection ai Download $
|
||||
toHereStart removewhen afile key ai
|
||||
toHereStart removewhen afile key ai si
|
||||
|
||||
describeMoveAction :: RemoveWhen -> String
|
||||
describeMoveAction RemoveNever = "copy"
|
||||
describeMoveAction _ = "move"
|
||||
|
||||
toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
|
||||
toStart removewhen afile key ai dest = do
|
||||
toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart
|
||||
toStart removewhen afile key ai si dest = do
|
||||
u <- getUUID
|
||||
if u == Remote.uuid dest
|
||||
then stop
|
||||
else toStart' dest removewhen afile key ai
|
||||
else toStart' dest removewhen afile key ai si
|
||||
|
||||
toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
||||
toStart' dest removewhen afile key ai = do
|
||||
toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart
|
||||
toStart' dest removewhen afile key ai si = do
|
||||
fast <- Annex.getState Annex.fast
|
||||
if fast && removewhen == RemoveNever
|
||||
then ifM (expectedPresent dest key)
|
||||
|
@ -121,7 +121,7 @@ toStart' dest removewhen afile key ai = do
|
|||
else go False (Remote.hasKey dest key)
|
||||
where
|
||||
go fastcheck isthere =
|
||||
starting (describeMoveAction removewhen) (OnlyActionOn key ai) $
|
||||
starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $
|
||||
toPerform dest removewhen key afile fastcheck =<< isthere
|
||||
|
||||
expectedPresent :: Remote -> Key -> Annex Bool
|
||||
|
@ -196,10 +196,10 @@ toPerform dest removewhen key afile fastcheck isthere =
|
|||
-- to be done except for cleaning up.
|
||||
lockfailed = next $ Command.Drop.cleanupLocal key
|
||||
|
||||
fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
|
||||
fromStart removewhen afile key ai src =
|
||||
fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart
|
||||
fromStart removewhen afile key ai si src =
|
||||
stopUnless (fromOk src key) $
|
||||
starting (describeMoveAction removewhen) (OnlyActionOn key ai) $
|
||||
starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $
|
||||
fromPerform src removewhen key afile
|
||||
|
||||
fromOk :: Remote -> Key -> Annex Bool
|
||||
|
@ -252,13 +252,13 @@ fromPerform src removewhen key afile = do
|
|||
-
|
||||
- When moving, the content is removed from all the reachable remotes that
|
||||
- it can safely be removed from. -}
|
||||
toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
||||
toHereStart removewhen afile key ai =
|
||||
toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart
|
||||
toHereStart removewhen afile key ai si =
|
||||
startingNoMessage (OnlyActionOn key ai) $ do
|
||||
rs <- Remote.keyPossibilities key
|
||||
forM_ rs $ \r ->
|
||||
includeCommandAction $
|
||||
starting (describeMoveAction removewhen) ai $
|
||||
starting (describeMoveAction removewhen) ai si $
|
||||
fromPerform r removewhen key afile
|
||||
next $ return True
|
||||
|
||||
|
|
|
@ -78,7 +78,7 @@ seek (MultiCastOptions Receive ups []) = commandAction $ receive ups
|
|||
seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send."
|
||||
|
||||
genAddress :: CommandStart
|
||||
genAddress = starting "gen-address" (ActionItemOther Nothing) $ do
|
||||
genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ do
|
||||
k <- uftpKey
|
||||
(s, ok) <- case k of
|
||||
KeyContainer s -> liftIO $ genkey (Param s)
|
||||
|
@ -127,7 +127,7 @@ send ups fs = do
|
|||
-- In a direct mode repository, the annex objects do not have
|
||||
-- the names of keys, and would have to be copied, which is too
|
||||
-- expensive.
|
||||
starting "sending files" (ActionItemOther Nothing) $
|
||||
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
|
||||
withTmpFile "send" $ \t h -> do
|
||||
let ww = WarnUnmatchLsFiles
|
||||
fs' <- seekHelper id ww LsFiles.inRepo
|
||||
|
@ -135,7 +135,7 @@ send ups fs = do
|
|||
matcher <- Limit.getMatcher
|
||||
let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $
|
||||
liftIO $ hPutStrLn h o
|
||||
forM_ fs' $ \f -> do
|
||||
forM_ fs' $ \(_, f) -> do
|
||||
mk <- lookupKey f
|
||||
case mk of
|
||||
Nothing -> noop
|
||||
|
@ -166,7 +166,7 @@ send ups fs = do
|
|||
next $ return True
|
||||
|
||||
receive :: [CommandParam] -> CommandStart
|
||||
receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do
|
||||
receive ups = starting "receiving multicast files" ai si $ do
|
||||
showNote "Will continue to run until stopped by ctrl-c"
|
||||
|
||||
showOutput
|
||||
|
@ -200,6 +200,9 @@ receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ d
|
|||
mapM_ storeReceived . lines =<< liftIO (hGetContents statush)
|
||||
showEndResult =<< liftIO (wait runner)
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther Nothing
|
||||
si = SeekInput []
|
||||
|
||||
storeReceived :: FilePath -> Annex ()
|
||||
storeReceived f = do
|
||||
|
|
|
@ -46,6 +46,9 @@ startGet = startingCustomOutput (ActionItemOther Nothing) $ next $ do
|
|||
return True
|
||||
|
||||
startSet :: Int -> CommandStart
|
||||
startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do
|
||||
startSet n = startingUsualMessages "numcopies" ai si $ do
|
||||
setGlobalNumCopies $ NumCopies n
|
||||
next $ return True
|
||||
where
|
||||
ai = ActionItemOther (Just $ show n)
|
||||
si = SeekInput [show n]
|
||||
|
|
|
@ -98,9 +98,11 @@ genAddresses addrs = do
|
|||
|
||||
-- Address is read from stdin, to avoid leaking it in shell history.
|
||||
linkRemote :: RemoteName -> CommandStart
|
||||
linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $
|
||||
linkRemote remotename = starting "p2p link" ai si $
|
||||
next promptaddr
|
||||
where
|
||||
ai = ActionItemOther (Just remotename)
|
||||
si = SeekInput []
|
||||
promptaddr = do
|
||||
liftIO $ putStrLn ""
|
||||
liftIO $ putStr "Enter peer address: "
|
||||
|
@ -124,10 +126,13 @@ linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename))
|
|||
startPairing :: RemoteName -> [P2PAddress] -> CommandStart
|
||||
startPairing _ [] = giveup "No P2P networks are currrently available."
|
||||
startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled)
|
||||
( starting "p2p pair" (ActionItemOther (Just remotename)) $
|
||||
( starting "p2p pair" ai si $
|
||||
performPairing remotename addrs
|
||||
, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/"
|
||||
)
|
||||
)
|
||||
where
|
||||
ai = ActionItemOther (Just remotename)
|
||||
si = SeekInput []
|
||||
|
||||
performPairing :: RemoteName -> [P2PAddress] -> CommandPerform
|
||||
performPairing remotename addrs = do
|
||||
|
|
|
@ -35,8 +35,8 @@ seek ps = do
|
|||
let ww = WarnUnmatchWorkTreeItems
|
||||
l <- workTreeItems ww ps
|
||||
-- fix symlinks to files being committed
|
||||
flip withFilesToBeCommitted l $ \f -> commandAction $
|
||||
maybe stop (Command.Fix.start Command.Fix.FixSymlinks f)
|
||||
flip withFilesToBeCommitted l $ \(si, f) -> commandAction $
|
||||
maybe stop (Command.Fix.start Command.Fix.FixSymlinks si f)
|
||||
=<< isAnnexLink f
|
||||
-- after a merge conflict or git cherry-pick or stash, pointer
|
||||
-- files in the worktree won't be populated, so populate them here
|
||||
|
@ -53,12 +53,18 @@ seek ps = do
|
|||
(removeViewMetaData v)
|
||||
|
||||
addViewMetaData :: View -> ViewedFile -> Key -> CommandStart
|
||||
addViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $
|
||||
addViewMetaData v f k = starting "metadata" ai si $
|
||||
next $ changeMetaData k $ fromView v f
|
||||
where
|
||||
ai = mkActionItem (k, toRawFilePath f)
|
||||
si = SeekInput []
|
||||
|
||||
removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart
|
||||
removeViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $
|
||||
removeViewMetaData v f k = starting "metadata" ai si $
|
||||
next $ changeMetaData k $ unsetMetaData $ fromView v f
|
||||
where
|
||||
ai = mkActionItem (k, toRawFilePath f)
|
||||
si = SeekInput []
|
||||
|
||||
changeMetaData :: Key -> MetaData -> CommandCleanup
|
||||
changeMetaData k metadata = do
|
||||
|
|
|
@ -52,21 +52,25 @@ batchParser s = case separate (== ' ') (reverse s) of
|
|||
|
||||
seek :: ReKeyOptions -> CommandSeek
|
||||
seek o = case batchOption o of
|
||||
Batch fmt -> batchInput fmt batchParser $
|
||||
batchCommandAction . start
|
||||
NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o)
|
||||
Batch fmt -> batchInput fmt batchParser
|
||||
(batchCommandAction . uncurry start)
|
||||
NoBatch -> withPairs
|
||||
(\(si, p) -> commandAction (start si (parsekey p)))
|
||||
(reKeyThese o)
|
||||
where
|
||||
parsekey (file, skey) =
|
||||
(toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey))
|
||||
|
||||
start :: (RawFilePath, Key) -> CommandStart
|
||||
start (file, newkey) = ifAnnexed file go stop
|
||||
start :: SeekInput -> (RawFilePath, Key) -> CommandStart
|
||||
start si (file, newkey) = ifAnnexed file go stop
|
||||
where
|
||||
go oldkey
|
||||
| oldkey == newkey = stop
|
||||
| otherwise = starting "rekey" (ActionItemWorkTreeFile file) $
|
||||
| otherwise = starting "rekey" ai si $
|
||||
perform file oldkey newkey
|
||||
|
||||
ai = ActionItemWorkTreeFile file
|
||||
|
||||
perform :: RawFilePath -> Key -> Key -> CommandPerform
|
||||
perform file oldkey newkey = do
|
||||
ifM (inAnnex oldkey)
|
||||
|
|
|
@ -24,8 +24,8 @@ cmd = noCommit $ command "recvkey" SectionPlumbing
|
|||
seek :: CmdParams -> CommandSeek
|
||||
seek = withKeys (commandAction . start)
|
||||
|
||||
start :: Key -> CommandStart
|
||||
start key = fieldTransfer Download key $ \_p -> do
|
||||
start :: (SeekInput, Key) -> CommandStart
|
||||
start (_, key) = fieldTransfer Download key $ \_p -> do
|
||||
-- Always verify content when a repo is sending an unlocked file,
|
||||
-- as the file could change while being transferred.
|
||||
fromunlocked <- (isJust <$> Fields.getField Fields.unlocked)
|
||||
|
|
|
@ -40,14 +40,16 @@ seek o = case (batchOption o, keyUrlPairs o) of
|
|||
|
||||
start :: [String] -> CommandStart
|
||||
start (keyname:url:[]) =
|
||||
starting "registerurl" (ActionItemOther (Just url)) $ do
|
||||
let key = keyOpt keyname
|
||||
perform key url
|
||||
starting "registerurl" ai si $
|
||||
perform (keyOpt keyname) url
|
||||
where
|
||||
ai = ActionItemOther (Just url)
|
||||
si = SeekInput [keyname, url]
|
||||
start _ = giveup "specify a key and an url"
|
||||
|
||||
startMass :: BatchFormat -> CommandStart
|
||||
startMass fmt =
|
||||
starting "registerurl" (ActionItemOther (Just "stdin")) $
|
||||
starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $
|
||||
massAdd fmt
|
||||
|
||||
massAdd :: BatchFormat -> CommandPerform
|
||||
|
|
|
@ -24,7 +24,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start ws = starting "reinit" (ActionItemOther (Just s)) $
|
||||
start ws = starting "reinit" (ActionItemOther (Just s)) (SeekInput ws) $
|
||||
perform s
|
||||
where
|
||||
s = unwords ws
|
||||
|
|
|
@ -41,20 +41,22 @@ seek os
|
|||
| otherwise = withWords (commandAction . startSrcDest) (params os)
|
||||
|
||||
startSrcDest :: [FilePath] -> CommandStart
|
||||
startSrcDest (src:dest:[])
|
||||
startSrcDest ps@(src:dest:[])
|
||||
| src == dest = stop
|
||||
| otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop
|
||||
where
|
||||
go key = starting "reinject" (ActionItemOther (Just src)) $
|
||||
go key = starting "reinject" ai si $
|
||||
ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src)
|
||||
( perform src key
|
||||
, giveup $ src ++ " does not have expected content of " ++ dest
|
||||
)
|
||||
ai = ActionItemOther (Just src)
|
||||
si = SeekInput ps
|
||||
startSrcDest _ = giveup "specify a src file and a dest file"
|
||||
|
||||
startKnown :: FilePath -> CommandStart
|
||||
startKnown src = notAnnexed src $
|
||||
starting "reinject" (ActionItemOther (Just src)) $ do
|
||||
starting "reinject" ai si $ do
|
||||
(key, _) <- genKey ks nullMeterUpdate Nothing
|
||||
ifM (isKnownKey key)
|
||||
( perform src key
|
||||
|
@ -65,6 +67,8 @@ startKnown src = notAnnexed src $
|
|||
where
|
||||
ks = KeySource src' src' Nothing
|
||||
src' = toRawFilePath src
|
||||
ai = ActionItemOther (Just src)
|
||||
si = SeekInput [src]
|
||||
|
||||
notAnnexed :: FilePath -> CommandStart -> CommandStart
|
||||
notAnnexed src a =
|
||||
|
|
|
@ -27,7 +27,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
|
||||
start ps@(oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
|
||||
Just (u, cfg, mcu) -> Annex.SpecialRemote.findExisting newname >>= \case
|
||||
Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote."
|
||||
Nothing -> go u cfg mcu
|
||||
|
@ -42,8 +42,9 @@ start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case
|
|||
Nothing -> giveup "That is not a special remote."
|
||||
Just cfg -> go u cfg Nothing
|
||||
where
|
||||
go u cfg mcu = starting "rename" (ActionItemOther Nothing) $
|
||||
perform u cfg mcu newname
|
||||
ai = ActionItemOther Nothing
|
||||
si = SeekInput ps
|
||||
go u cfg mcu = starting "rename" ai si $ perform u cfg mcu newname
|
||||
start _ = giveup "Specify an old name (or uuid or description) and a new name."
|
||||
|
||||
perform :: UUID -> R.RemoteConfig -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> String -> CommandPerform
|
||||
|
|
|
@ -25,7 +25,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withNothing (commandAction start)
|
||||
|
||||
start :: CommandStart
|
||||
start = starting "repair" (ActionItemOther Nothing) $
|
||||
start = starting "repair" (ActionItemOther Nothing) (SeekInput []) $
|
||||
next $ runRepair =<< Annex.getState Annex.force
|
||||
|
||||
runRepair :: Bool -> Annex Bool
|
||||
|
|
|
@ -24,7 +24,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withNothing (commandAction start)
|
||||
|
||||
start :: CommandStart
|
||||
start = starting "resolvemerge" (ActionItemOther Nothing) $ do
|
||||
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
|
||||
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
|
||||
d <- fromRawFilePath <$> fromRepo Git.localGitDir
|
||||
let merge_head = d </> "MERGE_HEAD"
|
||||
|
|
|
@ -30,8 +30,7 @@ optParser desc = RmUrlOptions
|
|||
|
||||
seek :: RmUrlOptions -> CommandSeek
|
||||
seek o = case batchOption o of
|
||||
Batch fmt -> batchInput fmt batchParser
|
||||
(batchCommandAction . start)
|
||||
Batch fmt -> batchInput fmt batchParser (batchCommandAction . start)
|
||||
NoBatch -> withPairs (commandAction . start) (rmThese o)
|
||||
|
||||
-- Split on the last space, since a FilePath can contain whitespace,
|
||||
|
@ -45,9 +44,10 @@ batchParser s = case separate (== ' ') (reverse s) of
|
|||
f' <- liftIO $ relPathCwdToFile f
|
||||
return $ Right (f', reverse ru)
|
||||
|
||||
start :: (FilePath, URLString) -> CommandStart
|
||||
start (file, url) = flip whenAnnexed file' $ \_ key ->
|
||||
starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $
|
||||
start :: (SeekInput, (FilePath, URLString)) -> CommandStart
|
||||
start (si, (file, url)) = flip whenAnnexed file' $ \_ key -> do
|
||||
let ai = mkActionItem (key, AssociatedFile (Just file'))
|
||||
starting "rmurl" ai si $
|
||||
next $ cleanup url key
|
||||
where
|
||||
file' = toRawFilePath file
|
||||
|
|
|
@ -29,9 +29,11 @@ start = parse
|
|||
u <- Remote.nameToUUID name
|
||||
startingCustomOutput (ActionItemOther Nothing) $
|
||||
performGet u
|
||||
parse (name:expr:[]) = do
|
||||
parse ps@(name:expr:[]) = do
|
||||
u <- Remote.nameToUUID name
|
||||
startingUsualMessages "schedule" (ActionItemOther (Just name)) $
|
||||
let ai = ActionItemOther (Just name)
|
||||
let si = SeekInput ps
|
||||
startingUsualMessages "schedule" ai si $
|
||||
performSet expr u
|
||||
parse _ = giveup "Specify a repository."
|
||||
|
||||
|
|
|
@ -26,8 +26,8 @@ cmd = noCommit $
|
|||
seek :: CmdParams -> CommandSeek
|
||||
seek = withKeys (commandAction . start)
|
||||
|
||||
start :: Key -> CommandStart
|
||||
start key = do
|
||||
start :: (SeekInput, Key) -> CommandStart
|
||||
start (_, key) = do
|
||||
opts <- filterRsyncSafeOptions . maybe [] words
|
||||
<$> getField "RsyncOptions"
|
||||
ifM (inAnnex key)
|
||||
|
|
|
@ -20,8 +20,11 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $
|
||||
start ps@(keyname:file:[]) = starting "setkey" ai si $
|
||||
perform file (keyOpt keyname)
|
||||
where
|
||||
ai = ActionItemOther (Just file)
|
||||
si = SeekInput ps
|
||||
start _ = giveup "specify a key and a content file"
|
||||
|
||||
keyOpt :: String -> Key
|
||||
|
|
|
@ -32,8 +32,8 @@ seek :: SetPresentKeyOptions -> CommandSeek
|
|||
seek o = case batchOption o of
|
||||
Batch fmt -> batchInput fmt
|
||||
(pure . parseKeyStatus . words)
|
||||
(batchCommandAction . start)
|
||||
NoBatch -> either giveup (commandAction . start)
|
||||
(batchCommandAction . uncurry start)
|
||||
NoBatch -> either giveup (commandAction . start (SeekInput (params o)))
|
||||
(parseKeyStatus $ params o)
|
||||
|
||||
data KeyStatus = KeyStatus Key UUID LogStatus
|
||||
|
@ -46,9 +46,10 @@ parseKeyStatus (ks:us:vs:[]) = do
|
|||
return $ KeyStatus k u s
|
||||
parseKeyStatus _ = Left "Bad input. Expected: key uuid value"
|
||||
|
||||
start :: KeyStatus -> CommandStart
|
||||
start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $
|
||||
perform k u s
|
||||
start :: SeekInput -> KeyStatus -> CommandStart
|
||||
start si (KeyStatus k u s) = starting "setpresentkey" ai si $ perform k u s
|
||||
where
|
||||
ai = mkActionItem k
|
||||
|
||||
perform :: Key -> UUID -> LogStatus -> CommandPerform
|
||||
perform k u s = next $ do
|
||||
|
|
|
@ -308,7 +308,7 @@ syncRemotes' ps available =
|
|||
fastest = fromMaybe [] . headMaybe . Remote.byCost
|
||||
|
||||
commit :: SyncOptions -> CommandStart
|
||||
commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do
|
||||
commit o = stopUnless shouldcommit $ starting "commit" ai si $ do
|
||||
commitmessage <- maybe commitMsg return (messageOption o)
|
||||
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
||||
next $ do
|
||||
|
@ -324,6 +324,8 @@ commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing)
|
|||
( pure (commitOption o)
|
||||
<||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit)
|
||||
)
|
||||
ai = ActionItemOther Nothing
|
||||
si = SeekInput []
|
||||
|
||||
commitMsg :: Annex String
|
||||
commitMsg = do
|
||||
|
@ -350,14 +352,18 @@ mergeLocal' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandSt
|
|||
mergeLocal' mergeconfig o currbranch@(Just branch, _) =
|
||||
needMerge currbranch branch >>= \case
|
||||
Nothing -> stop
|
||||
Just syncbranch ->
|
||||
starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $
|
||||
Just syncbranch -> do
|
||||
let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)
|
||||
let si = SeekInput []
|
||||
starting "merge" ai si $
|
||||
next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch
|
||||
mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case
|
||||
Just branch -> needMerge currbranch branch >>= \case
|
||||
Nothing -> stop
|
||||
Just syncbranch ->
|
||||
starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do
|
||||
Just syncbranch -> do
|
||||
let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)
|
||||
let si = SeekInput []
|
||||
starting "merge" ai si $ do
|
||||
warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it."
|
||||
next $ return False
|
||||
Nothing -> stop
|
||||
|
@ -421,7 +427,7 @@ updateBranch syncbranch updateto g =
|
|||
|
||||
pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart
|
||||
pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $
|
||||
starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do
|
||||
starting "pull" ai si $ do
|
||||
showOutput
|
||||
ifM (onlyAnnex o)
|
||||
( do
|
||||
|
@ -443,6 +449,8 @@ pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && want
|
|||
[Param "fetch", Param $ Remote.name remote]
|
||||
++ map Param bs
|
||||
wantpull = remoteAnnexPull (Remote.gitconfig remote)
|
||||
ai = ActionItemOther (Just (Remote.name remote))
|
||||
si = SeekInput []
|
||||
|
||||
importRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek
|
||||
importRemote o mergeconfig remote currbranch
|
||||
|
@ -489,7 +497,7 @@ pushRemote o remote (Just branch, _) = do
|
|||
onlyannex <- onlyAnnex o
|
||||
let mainbranch = if onlyannex then Nothing else Just branch
|
||||
stopUnless (pure (pushOption o) <&&> needpush mainbranch) $
|
||||
starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do
|
||||
starting "push" ai si $ next $ do
|
||||
repo <- Remote.getRepo remote
|
||||
showOutput
|
||||
ok <- inRepoWithSshOptionsTo repo gc $
|
||||
|
@ -500,6 +508,8 @@ pushRemote o remote (Just branch, _) = do
|
|||
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
|
||||
return ok
|
||||
where
|
||||
ai = ActionItemOther (Just (Remote.name remote))
|
||||
si = SeekInput []
|
||||
gc = Remote.gitconfig remote
|
||||
needpush mainbranch
|
||||
| remoteAnnexReadOnly gc = return False
|
||||
|
@ -663,15 +673,15 @@ seekSyncContent o rs currbranch = do
|
|||
seekHelper fst3 ww LsFiles.inRepoDetails l
|
||||
|
||||
seekincludinghidden origbranch mvar l bloomfeeder =
|
||||
seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $
|
||||
seekFiltered (\(si, f) -> ifAnnexed f (commandAction . gofile bloomfeeder mvar si f) noop) $
|
||||
seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l
|
||||
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
gofile bloom mvar f k =
|
||||
gofile bloom mvar _ f k =
|
||||
go (Right bloom) mvar (AssociatedFile (Just f)) k
|
||||
|
||||
gokey mvar bloom (k, _) =
|
||||
gokey mvar bloom (_, k, _) =
|
||||
go (Left bloom) mvar (AssociatedFile Nothing) k
|
||||
|
||||
go ebloom mvar af k = do
|
||||
|
@ -725,7 +735,7 @@ syncFile ebloom rs af k = do
|
|||
-- includeCommandAction for drops,
|
||||
-- because a failure to drop does not mean
|
||||
-- the sync failed.
|
||||
handleDropsFrom locs' rs "unwanted" True k af []
|
||||
handleDropsFrom locs' rs "unwanted" True k af si []
|
||||
callCommandAction
|
||||
|
||||
return (got || not (null putrs))
|
||||
|
@ -739,7 +749,7 @@ syncFile ebloom rs af k = do
|
|||
( return [ get have ]
|
||||
, return []
|
||||
)
|
||||
get have = includeCommandAction $ starting "get" ai $
|
||||
get have = includeCommandAction $ starting "get" ai si $
|
||||
stopUnless (getKey' k af have) $
|
||||
next $ return True
|
||||
|
||||
|
@ -755,9 +765,10 @@ syncFile ebloom rs af k = do
|
|||
, return []
|
||||
)
|
||||
put dest = includeCommandAction $
|
||||
Command.Move.toStart' dest Command.Move.RemoveNever af k ai
|
||||
Command.Move.toStart' dest Command.Move.RemoveNever af k ai si
|
||||
|
||||
ai = mkActionItem (k, af)
|
||||
si = SeekInput []
|
||||
|
||||
{- When a remote has an annex-tracking-branch configuration, change the export
|
||||
- to contain the current content of the branch. Otherwise, transfer any files
|
||||
|
@ -814,22 +825,21 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
|
|||
|
||||
cleanupLocal :: CurrBranch -> CommandStart
|
||||
cleanupLocal (Nothing, _) = stop
|
||||
cleanupLocal (Just currb, _) =
|
||||
starting "cleanup" (ActionItemOther (Just "local")) $
|
||||
next $ do
|
||||
delbranch $ syncBranch currb
|
||||
delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
|
||||
mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r)
|
||||
=<< listTaggedBranches
|
||||
return True
|
||||
cleanupLocal (Just currb, _) = starting "cleanup" ai si $ next $ do
|
||||
delbranch $ syncBranch currb
|
||||
delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name
|
||||
mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r) =<< listTaggedBranches
|
||||
return True
|
||||
where
|
||||
delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $
|
||||
inRepo $ Git.Branch.delete b
|
||||
ai = ActionItemOther (Just "local")
|
||||
si = SeekInput []
|
||||
|
||||
cleanupRemote :: Remote -> CurrBranch -> CommandStart
|
||||
cleanupRemote _ (Nothing, _) = stop
|
||||
cleanupRemote remote (Just b, _) =
|
||||
starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $
|
||||
starting "cleanup" ai si $
|
||||
next $ inRepo $ Git.Command.runBool
|
||||
[ Param "push"
|
||||
, Param "--quiet"
|
||||
|
@ -839,7 +849,10 @@ cleanupRemote remote (Just b, _) =
|
|||
, Param $ Git.fromRef $ syncBranch $
|
||||
Git.Ref.base $ Annex.Branch.name
|
||||
]
|
||||
|
||||
where
|
||||
ai = ActionItemOther (Just (Remote.name remote))
|
||||
si = SeekInput []
|
||||
|
||||
shouldSyncContent :: SyncOptions -> Annex Bool
|
||||
shouldSyncContent o
|
||||
| noContentOption o = pure False
|
||||
|
|
|
@ -73,7 +73,7 @@ seek :: TestRemoteOptions -> CommandSeek
|
|||
seek = commandAction . start
|
||||
|
||||
start :: TestRemoteOptions -> CommandStart
|
||||
start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
|
||||
start o = starting "testremote" (ActionItemOther (Just (testRemote o))) si $ do
|
||||
fast <- Annex.getState Annex.fast
|
||||
cache <- liftIO newRemoteVariantCache
|
||||
r <- either giveup (disableExportTree cache)
|
||||
|
@ -98,6 +98,7 @@ start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do
|
|||
perform drs unavailr exportr ks
|
||||
where
|
||||
basesz = fromInteger $ sizeOption o
|
||||
si = SeekInput [testRemote o]
|
||||
|
||||
perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform
|
||||
perform drs unavailr exportr ks = do
|
||||
|
|
|
@ -44,8 +44,8 @@ instance DeferredParseClass TransferKeyOptions where
|
|||
seek :: TransferKeyOptions -> CommandSeek
|
||||
seek o = withKeys (commandAction . start o) (keyOptions o)
|
||||
|
||||
start :: TransferKeyOptions -> Key -> CommandStart
|
||||
start o key = startingCustomOutput key $ case fromToOptions o of
|
||||
start :: TransferKeyOptions -> (SeekInput, Key) -> CommandStart
|
||||
start o (_, key) = startingCustomOutput key $ case fromToOptions o of
|
||||
ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest
|
||||
FromRemote src -> fromPerform key (fileOption o) =<< getParsed src
|
||||
|
||||
|
|
|
@ -28,7 +28,8 @@ trustCommand c level = withWords (commandAction . start)
|
|||
start ws = do
|
||||
let name = unwords ws
|
||||
u <- Remote.nameToUUID name
|
||||
starting c (ActionItemOther (Just name)) (perform u)
|
||||
let si = SeekInput ws
|
||||
starting c (ActionItemOther (Just name)) si (perform u)
|
||||
perform uuid = do
|
||||
trustSet uuid level
|
||||
when (level == DeadTrusted) $
|
||||
|
|
|
@ -33,9 +33,9 @@ seeker = AnnexedFileSeeker
|
|||
, usesLocationLog = False
|
||||
}
|
||||
|
||||
start :: RawFilePath -> Key -> CommandStart
|
||||
start file key =
|
||||
starting "unannex" (mkActionItem (key, file)) $
|
||||
start :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start si file key =
|
||||
starting "unannex" (mkActionItem (key, file)) si $
|
||||
perform file key
|
||||
|
||||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
|
|
|
@ -41,8 +41,11 @@ seek ps = do
|
|||
withStrings (commandAction . start) ps
|
||||
|
||||
start :: FilePath -> CommandStart
|
||||
start p = starting "undo" (ActionItemOther (Just p)) $
|
||||
start p = starting "undo" ai si $
|
||||
perform p
|
||||
where
|
||||
ai = ActionItemOther (Just p)
|
||||
si = SeekInput [p]
|
||||
|
||||
perform :: FilePath -> CommandPerform
|
||||
perform p = do
|
||||
|
|
|
@ -24,7 +24,7 @@ seek = withWords (commandAction . start)
|
|||
start :: [String] -> CommandStart
|
||||
start (name:g:[]) = do
|
||||
u <- Remote.nameToUUID name
|
||||
starting "ungroup" (ActionItemOther (Just name)) $
|
||||
starting "ungroup" (ActionItemOther (Just name)) (SeekInput [name, g]) $
|
||||
perform u (toGroup g)
|
||||
start _ = giveup "Specify a repository and a group."
|
||||
|
||||
|
|
|
@ -42,7 +42,7 @@ check = do
|
|||
seek :: CmdParams -> CommandSeek
|
||||
seek ps = do
|
||||
l <- workTreeItems ww ps
|
||||
withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l
|
||||
withFilesNotInGit WarnUnmatchWorkTreeItems (\(_, f) -> commandAction $ whenAnnexed (startCheckIncomplete . fromRawFilePath) f) l
|
||||
Annex.changeState $ \s -> s { Annex.fast = True }
|
||||
withFilesInGitAnnex ww Command.Unannex.seeker l
|
||||
finish
|
||||
|
|
|
@ -36,12 +36,13 @@ seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
|
|||
, usesLocationLog = False
|
||||
}
|
||||
|
||||
start :: RawFilePath -> Key -> CommandStart
|
||||
start file key = ifM (isJust <$> isAnnexLink file)
|
||||
( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $
|
||||
perform file key
|
||||
start :: SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start si file key = ifM (isJust <$> isAnnexLink file)
|
||||
( starting "unlock" ai si $ perform file key
|
||||
, stop
|
||||
)
|
||||
where
|
||||
ai = mkActionItem (key, AssociatedFile (Just file))
|
||||
|
||||
perform :: RawFilePath -> Key -> CommandPerform
|
||||
perform dest key = do
|
||||
|
|
|
@ -73,7 +73,7 @@ start o = do
|
|||
Just "." -> (".", checkUnused refspec)
|
||||
Just "here" -> (".", checkUnused refspec)
|
||||
Just n -> (n, checkRemoteUnused n refspec)
|
||||
starting "unused" (ActionItemOther (Just name)) perform
|
||||
starting "unused" (ActionItemOther (Just name)) (SeekInput []) perform
|
||||
|
||||
checkUnused :: RefSpec -> CommandPerform
|
||||
checkUnused refspec = chain 0
|
||||
|
@ -337,4 +337,5 @@ startUnused message unused badunused tmpunused maps n = search
|
|||
Nothing -> search rest
|
||||
Just key -> starting message
|
||||
(ActionItemOther $ Just $ show n)
|
||||
(SeekInput [])
|
||||
(a key)
|
||||
|
|
|
@ -39,10 +39,10 @@ seek o = commandAction (start o)
|
|||
|
||||
start :: UpgradeOptions -> CommandStart
|
||||
start (UpgradeOptions { autoOnly = True }) = do
|
||||
starting "upgrade" (ActionItemOther Nothing) $ do
|
||||
starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do
|
||||
getVersion >>= maybe noop checkUpgrade
|
||||
next $ return True
|
||||
start _ = starting "upgrade" (ActionItemOther Nothing) $ do
|
||||
start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do
|
||||
whenM (isNothing <$> getVersion) $ do
|
||||
initialize Nothing Nothing
|
||||
r <- upgrade False latestVersion
|
||||
|
|
|
@ -22,7 +22,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start params = starting "vadd" (ActionItemOther Nothing) $
|
||||
start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $
|
||||
withCurrentView $ \view -> do
|
||||
let (view', change) = refineView view $
|
||||
map parseViewParam $ reverse params
|
||||
|
|
|
@ -26,7 +26,7 @@ start ::CommandStart
|
|||
start = go =<< currentView
|
||||
where
|
||||
go Nothing = giveup "Not in a view."
|
||||
go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do
|
||||
go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput [])$ do
|
||||
let v' = v { viewComponents = vcycle [] (viewComponents v) }
|
||||
if v == v'
|
||||
then do
|
||||
|
|
|
@ -20,7 +20,7 @@ seek :: CmdParams -> CommandSeek
|
|||
seek = withWords (commandAction . start)
|
||||
|
||||
start :: [String] -> CommandStart
|
||||
start params = starting "vfilter" (ActionItemOther Nothing) $
|
||||
start params = starting "vfilter" (ActionItemOther Nothing) (SeekInput params) $
|
||||
withCurrentView $ \view -> do
|
||||
let view' = filterView view $
|
||||
map parseViewParam $ reverse params
|
||||
|
|
|
@ -27,7 +27,7 @@ start :: [String] -> CommandStart
|
|||
start ps = go =<< currentView
|
||||
where
|
||||
go Nothing = giveup "Not in a view."
|
||||
go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do
|
||||
go (Just v) = starting "vpop" ai si $ do
|
||||
removeView v
|
||||
(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)
|
||||
<$> recentViews
|
||||
|
@ -46,3 +46,7 @@ start ps = go =<< currentView
|
|||
sameparentbranch a b = viewParentBranch a == viewParentBranch b
|
||||
|
||||
num = fromMaybe 1 $ readish =<< headMaybe ps
|
||||
|
||||
ai = ActionItemOther (Just $ show num)
|
||||
|
||||
si = SeekInput ps
|
||||
|
|
|
@ -36,7 +36,9 @@ start ps = ifM safeToEnterView
|
|||
, giveup "Not safe to enter view."
|
||||
)
|
||||
where
|
||||
go view Nothing = starting "view" (ActionItemOther Nothing) $
|
||||
ai = ActionItemOther Nothing
|
||||
si = SeekInput ps
|
||||
go view Nothing = starting "view" ai si $
|
||||
perform view
|
||||
go view (Just v)
|
||||
| v == view = stop
|
||||
|
|
|
@ -36,9 +36,11 @@ cmd' name desc getter setter = noMessages $
|
|||
u <- Remote.nameToUUID rname
|
||||
startingCustomOutput (ActionItemOther Nothing) $
|
||||
performGet getter u
|
||||
start (rname:expr:[]) = do
|
||||
start ps@(rname:expr:[]) = do
|
||||
u <- Remote.nameToUUID rname
|
||||
startingUsualMessages name (ActionItemOther (Just rname)) $
|
||||
let si = SeekInput ps
|
||||
let ai = ActionItemOther (Just rname)
|
||||
startingUsualMessages name ai si $
|
||||
performSet setter expr u
|
||||
start _ = giveup "Specify a repository."
|
||||
|
||||
|
|
|
@ -66,16 +66,16 @@ seek o = do
|
|||
where
|
||||
ww = WarnUnmatchLsFiles
|
||||
|
||||
start :: WhereisOptions -> M.Map UUID Remote -> RawFilePath -> Key -> CommandStart
|
||||
start o remotemap file key =
|
||||
startKeys o remotemap (key, mkActionItem (key, afile))
|
||||
start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
|
||||
start o remotemap si file key =
|
||||
startKeys o remotemap (si, key, mkActionItem (key, afile))
|
||||
where
|
||||
afile = AssociatedFile (Just file)
|
||||
|
||||
startKeys :: WhereisOptions -> M.Map UUID Remote -> (Key, ActionItem) -> CommandStart
|
||||
startKeys o remotemap (key, ai)
|
||||
startKeys :: WhereisOptions -> M.Map UUID Remote -> (SeekInput, Key, ActionItem) -> CommandStart
|
||||
startKeys o remotemap (si, key, ai)
|
||||
| isJust (formatOption o) = startingCustomOutput ai go
|
||||
| otherwise = starting "whereis" ai go
|
||||
| otherwise = starting "whereis" ai si go
|
||||
where
|
||||
go = perform o remotemap key ai
|
||||
|
||||
|
|
12
Messages.hs
12
Messages.hs
|
@ -90,19 +90,19 @@ showStartKey command key i = outputMessage json $
|
|||
json = JSON.start command (actionItemWorkTreeFile i) (Just key)
|
||||
|
||||
showStartMessage :: StartMessage -> Annex ()
|
||||
showStartMessage (StartMessage command ai) = case ai of
|
||||
showStartMessage (StartMessage command ai si) = case ai of
|
||||
ActionItemAssociatedFile _ k -> showStartKey command k ai
|
||||
ActionItemKey k -> showStartKey command k ai
|
||||
ActionItemBranchFilePath _ k -> showStartKey command k ai
|
||||
ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai
|
||||
ActionItemWorkTreeFile file -> showStart command file
|
||||
ActionItemOther msg -> showStart' command msg
|
||||
OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai')
|
||||
showStartMessage (StartUsualMessages command ai) = do
|
||||
OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai' si)
|
||||
showStartMessage (StartUsualMessages command ai si) = do
|
||||
outputType <$> Annex.getState Annex.output >>= \case
|
||||
QuietOutput -> Annex.setOutput NormalOutput
|
||||
_ -> noop
|
||||
showStartMessage (StartMessage command ai)
|
||||
showStartMessage (StartMessage command ai si)
|
||||
showStartMessage (StartNoMessage _) = noop
|
||||
showStartMessage (CustomOutput _) =
|
||||
outputType <$> Annex.getState Annex.output >>= \case
|
||||
|
@ -111,8 +111,8 @@ showStartMessage (CustomOutput _) =
|
|||
|
||||
-- Only show end result if the StartMessage is one that gets displayed.
|
||||
showEndMessage :: StartMessage -> Bool -> Annex ()
|
||||
showEndMessage (StartMessage _ _) = showEndResult
|
||||
showEndMessage (StartUsualMessages _ _) = showEndResult
|
||||
showEndMessage (StartMessage _ _ _) = showEndResult
|
||||
showEndMessage (StartUsualMessages _ _ _) = showEndResult
|
||||
showEndMessage (StartNoMessage _) = const noop
|
||||
showEndMessage (CustomOutput _) = const noop
|
||||
|
||||
|
|
|
@ -38,13 +38,18 @@ type CommandPerform = Annex (Maybe CommandCleanup)
|
|||
- returns the overall success/fail of the command. -}
|
||||
type CommandCleanup = Annex Bool
|
||||
|
||||
{- Input that was seeked on to make an ActionItem. Eg, the input filename,
|
||||
- or directory name. -}
|
||||
newtype SeekInput = SeekInput [String]
|
||||
deriving (Show)
|
||||
|
||||
{- Message that is displayed when starting to perform an action on
|
||||
- something. The String is typically the name of the command or action
|
||||
- being performed.
|
||||
-}
|
||||
data StartMessage
|
||||
= StartMessage String ActionItem
|
||||
| StartUsualMessages String ActionItem
|
||||
= StartMessage String ActionItem SeekInput
|
||||
| StartUsualMessages String ActionItem SeekInput
|
||||
-- ^ Like StartMessage, but makes sure to enable usual message
|
||||
-- display in case it was disabled by cmdnomessages.
|
||||
| StartNoMessage ActionItem
|
||||
|
@ -56,8 +61,8 @@ data StartMessage
|
|||
deriving (Show)
|
||||
|
||||
instance MkActionItem StartMessage where
|
||||
mkActionItem (StartMessage _ ai) = ai
|
||||
mkActionItem (StartUsualMessages _ ai) = ai
|
||||
mkActionItem (StartMessage _ ai _) = ai
|
||||
mkActionItem (StartUsualMessages _ ai _) = ai
|
||||
mkActionItem (StartNoMessage ai) = ai
|
||||
mkActionItem (CustomOutput ai) = ai
|
||||
|
||||
|
|
|
@ -19,7 +19,9 @@ module Utility.Path (
|
|||
relPathDirToFile,
|
||||
relPathDirToFileAbs,
|
||||
segmentPaths,
|
||||
segmentPaths',
|
||||
runSegmentPaths,
|
||||
runSegmentPaths',
|
||||
relHome,
|
||||
inPath,
|
||||
searchPath,
|
||||
|
@ -215,15 +217,19 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
|
|||
- that many paths in doesn't care too much about order of the later ones.
|
||||
-}
|
||||
segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]]
|
||||
segmentPaths _ [] new = [new]
|
||||
segmentPaths _ [_] new = [new] -- optimisation
|
||||
segmentPaths c (l:ls) new = found : segmentPaths c ls rest
|
||||
segmentPaths = segmentPaths' (\_ r -> r)
|
||||
|
||||
segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]]
|
||||
segmentPaths' f _ [] new = [map (f Nothing) new]
|
||||
segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation
|
||||
segmentPaths' f c (i:is) new =
|
||||
map (f (Just i)) found : segmentPaths' f c is rest
|
||||
where
|
||||
(found, rest) = if length ls < 100
|
||||
then partition inl new
|
||||
else break (not . inl) new
|
||||
inl f = l' `dirContains` fromRawFilePath (c f)
|
||||
l' = fromRawFilePath l
|
||||
(found, rest) = if length is < 100
|
||||
then partition ini new
|
||||
else break (not . ini) new
|
||||
ini f = i' `dirContains` fromRawFilePath (c f)
|
||||
i' = fromRawFilePath i
|
||||
|
||||
{- This assumes that it's cheaper to call segmentPaths on the result,
|
||||
- than it would be to run the action separately with each path. In
|
||||
|
@ -232,6 +238,9 @@ segmentPaths c (l:ls) new = found : segmentPaths c ls rest
|
|||
runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]]
|
||||
runSegmentPaths c a paths = segmentPaths c paths <$> a paths
|
||||
|
||||
runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[r]]
|
||||
runSegmentPaths' si c a paths = segmentPaths' si c paths <$> a paths
|
||||
|
||||
{- Converts paths in the home directory to use ~/ -}
|
||||
relHome :: FilePath -> IO String
|
||||
relHome path = do
|
||||
|
|
Loading…
Reference in a new issue