- 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
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)
[] -> 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
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. -}
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
import Annex.Content
import Annex.Wanted
import CmdLine.Action
+import Types.Command
import qualified Data.Set as S
import Control.Concurrent
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)
+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
-- 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 = (,,)
<*> 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
-- 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
-- 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
import System.Posix.Types
data AnnexedFileSeeker = AnnexedFileSeeker
- { startAction :: RawFilePath -> Key -> CommandStart
+ { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart
, checkContentPresent :: Maybe Bool
, usesLocationLog :: Bool
}
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
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
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
:: Maybe KeyOptions
-> Bool
-> AnnexedFileSeeker
- -> ((Key, ActionItem) -> CommandSeek)
+ -> ((SeekInput, Key, ActionItem) -> CommandSeek)
-> (WorkTreeItems -> CommandSeek)
-> WorkTreeItems
-> CommandSeek
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)
withKeyOptions'
:: Maybe KeyOptions
-> Bool
- -> Annex ((Key, ActionItem) -> Annex ())
+ -> Annex ((SeekInput, Key, ActionItem) -> Annex ())
-> (WorkTreeItems -> CommandSeek)
-> WorkTreeItems
-> CommandSeek
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
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
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")
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
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) $
-- 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
-- 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
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
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. -}
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 ->
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
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
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
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
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
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
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
(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
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
{- 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)]
start :: Adjustment -> CommandStart
start adj = do
checkVersionSupported
- starting "adjust" (ActionItemOther Nothing) $
+ starting "adjust" (ActionItemOther Nothing) (SeekInput []) $
next $ enterAdjustedBranch adj
(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
(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"
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
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
(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
{- 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 (<)
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
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
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
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
-- 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
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
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
(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
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
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
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
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
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
| 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 =
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 ()
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
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
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
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.
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)
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
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
(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
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!"
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)
<||> 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
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) $
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
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."
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
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
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 =
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
globalInfo o
stop
start o ps = do
- mapM_ (itemInfo o) ps
+ mapM_ (\p -> itemInfo o (SeekInput [p], p)) ps
stop
globalInfo :: InfoOptions -> Annex ()
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
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
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
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
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
, 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
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
(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
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 []
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
(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
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
, 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
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
, 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
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
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)
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
-- 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
-
- 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
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)
-- 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
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
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
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
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]
-- 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: "
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
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
(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
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)
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)
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
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
| 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
where
ks = KeySource src' src' Nothing
src' = toRawFilePath src
+ ai = ActionItemOther (Just src)
+ si = SeekInput [src]
notAnnexed :: FilePath -> CommandStart -> CommandStart
notAnnexed src a =
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
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
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
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"
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,
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
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."
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)
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
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
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
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
( pure (commitOption o)
<||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit)
)
+ ai = ActionItemOther Nothing
+ si = SeekInput []
commitMsg :: Annex String
commitMsg = do
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
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
[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
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 $
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
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
-- 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))
( 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
, 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
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"
, 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
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)
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
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
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) $
, 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
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
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."
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
, 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
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
Nothing -> search rest
Just key -> starting message
(ActionItemOther $ Just $ show n)
+ (SeekInput [])
(a key)
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
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
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
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
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
sameparentbranch a b = viewParentBranch a == viewParentBranch b
num = fromMaybe 1 $ readish =<< headMaybe ps
+
+ ai = ActionItemOther (Just $ show num)
+
+ si = SeekInput ps
, 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
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."
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
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
-- 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
- 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
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
relPathDirToFile,
relPathDirToFileAbs,
segmentPaths,
+ segmentPaths',
runSegmentPaths,
+ runSegmentPaths',
relHome,
inPath,
searchPath,
- 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
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
projects / git-annex.git / commitdiff