filter out control characters in all other Messages
This does, as a side effect, make long notes in json output not be indented. The indentation is only needed to offset them underneath the display of the file they apply to, so that's ok. Sponsored-by: Brock Spratlen on Patreon
This commit is contained in:
parent
a0e6fa18eb
commit
8b6c7bdbcc
54 changed files with 183 additions and 164 deletions
|
@ -98,7 +98,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
|
||||||
-- (for an unknown reason).
|
-- (for an unknown reason).
|
||||||
-- http://thread.gmane.org/gmane.comp.version-control.git/297237
|
-- http://thread.gmane.org/gmane.comp.version-control.git/297237
|
||||||
inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"]
|
inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"]
|
||||||
showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch)
|
showAction $ UnquotedString $ "Merging into " ++ fromRef (Git.Ref.base origbranch)
|
||||||
merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True
|
merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True
|
||||||
(const $ resolveMerge (Just updatedorig) tomerge True)
|
(const $ resolveMerge (Just updatedorig) tomerge True)
|
||||||
if merged
|
if merged
|
||||||
|
|
|
@ -243,7 +243,7 @@ updateTo' pairs = do
|
||||||
" into " ++ fromRef name
|
" into " ++ fromRef name
|
||||||
localtransitions <- getLocalTransitions
|
localtransitions <- getLocalTransitions
|
||||||
unless (null tomerge) $ do
|
unless (null tomerge) $ do
|
||||||
showSideAction merge_desc
|
showSideAction (UnquotedString merge_desc)
|
||||||
mapM_ checkBranchDifferences refs
|
mapM_ checkBranchDifferences refs
|
||||||
mergeIndex jl refs
|
mergeIndex jl refs
|
||||||
let commitrefs = nub $ fullname:refs
|
let commitrefs = nub $ fullname:refs
|
||||||
|
|
|
@ -404,8 +404,8 @@ checkSqliteWorks = do
|
||||||
Right () -> return ()
|
Right () -> return ()
|
||||||
Left e -> do
|
Left e -> do
|
||||||
showLongNote $ "Detected a filesystem where Sqlite does not work."
|
showLongNote $ "Detected a filesystem where Sqlite does not work."
|
||||||
showLongNote $ "(" ++ show e ++ ")"
|
showLongNote $ UnquotedString $ "(" ++ show e ++ ")"
|
||||||
showLongNote $ "To work around this problem, you can set annex.dbdir " ++
|
showLongNote $ "To work around this problem, you can set annex.dbdir " <>
|
||||||
"to a directory on another filesystem."
|
"to a directory on another filesystem."
|
||||||
showLongNote $ "For example: git config annex.dbdir $HOME/cache/git-annex"
|
showLongNote $ "For example: git config annex.dbdir $HOME/cache/git-annex"
|
||||||
giveup "Not initialized."
|
giveup "Not initialized."
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-}
|
||||||
|
|
||||||
module Annex.NumCopies (
|
module Annex.NumCopies (
|
||||||
module Types.NumCopies,
|
module Types.NumCopies,
|
||||||
|
@ -277,17 +277,17 @@ notEnoughCopies :: Key -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] ->
|
||||||
notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do
|
notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do
|
||||||
showNote "unsafe"
|
showNote "unsafe"
|
||||||
if length have < fromNumCopies neednum
|
if length have < fromNumCopies neednum
|
||||||
then showLongNote $
|
then showLongNote $ UnquotedString $
|
||||||
"Could only verify the existence of " ++
|
"Could only verify the existence of " ++
|
||||||
show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++
|
show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++
|
||||||
" necessary " ++ pluralcopies (fromNumCopies neednum)
|
" necessary " ++ pluralcopies (fromNumCopies neednum)
|
||||||
else do
|
else do
|
||||||
showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++
|
showLongNote $ UnquotedString $ "Unable to lock down " ++ show (fromMinCopies needmin) ++
|
||||||
" " ++ pluralcopies (fromMinCopies needmin) ++
|
" " ++ pluralcopies (fromMinCopies needmin) ++
|
||||||
" of file necessary to safely drop it."
|
" of file necessary to safely drop it."
|
||||||
if null lockunsupported
|
if null lockunsupported
|
||||||
then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
|
then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
|
||||||
else showLongNote $ "These remotes do not support locking: "
|
else showLongNote $ UnquotedString $ "These remotes do not support locking: "
|
||||||
++ Remote.listRemoteNames lockunsupported
|
++ Remote.listRemoteNames lockunsupported
|
||||||
|
|
||||||
Remote.showTriedRemotes bad
|
Remote.showTriedRemotes bad
|
||||||
|
|
|
@ -96,7 +96,7 @@ autoEnable = do
|
||||||
Nothing -> cu
|
Nothing -> cu
|
||||||
case (lookupName c, findType c) of
|
case (lookupName c, findType c) of
|
||||||
(Just name, Right t) -> do
|
(Just name, Right t) -> do
|
||||||
showSideAction $ "Auto enabling special remote " ++ name
|
showSideAction $ UnquotedString $ "Auto enabling special remote " ++ name
|
||||||
dummycfg <- liftIO dummyRemoteGitConfig
|
dummycfg <- liftIO dummyRemoteGitConfig
|
||||||
tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case
|
tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case
|
||||||
Left e -> warning (UnquotedString (show e))
|
Left e -> warning (UnquotedString (show e))
|
||||||
|
|
|
@ -339,7 +339,7 @@ configuredRetry numretries _old new = do
|
||||||
if numretries < maxretries
|
if numretries < maxretries
|
||||||
then do
|
then do
|
||||||
let retrydelay = Seconds (initretrydelay * 2^(numretries-1))
|
let retrydelay = Seconds (initretrydelay * 2^(numretries-1))
|
||||||
showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."
|
showSideAction $ UnquotedString $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."
|
||||||
liftIO $ threadDelaySeconds retrydelay
|
liftIO $ threadDelaySeconds retrydelay
|
||||||
return True
|
return True
|
||||||
else return False
|
else return False
|
||||||
|
|
|
@ -128,7 +128,7 @@ resumeVerifyKeyContent k f iv = liftIO (positionIncrementalVerifier iv) >>= \cas
|
||||||
liftIO $ catchDefaultIO (Just False) $
|
liftIO $ catchDefaultIO (Just False) $
|
||||||
finalizeIncrementalVerifier iv
|
finalizeIncrementalVerifier iv
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
showAction (descIncrementalVerifier iv)
|
showAction (UnquotedString (descIncrementalVerifier iv))
|
||||||
liftIO $ catchDefaultIO (Just False) $
|
liftIO $ catchDefaultIO (Just False) $
|
||||||
withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
|
withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
|
||||||
hSeek h AbsoluteSeek endpos
|
hSeek h AbsoluteSeek endpos
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, CPP #-}
|
||||||
|
|
||||||
module Assistant.Threads.Watcher (
|
module Assistant.Threads.Watcher (
|
||||||
watchThread,
|
watchThread,
|
||||||
|
|
|
@ -124,7 +124,7 @@ checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do
|
||||||
exists <- liftIO $ R.doesPathExist file
|
exists <- liftIO $ R.doesPathExist file
|
||||||
case (exists, fast) of
|
case (exists, fast) of
|
||||||
(True, False) -> do
|
(True, False) -> do
|
||||||
showAction descChecksum
|
showAction (UnquotedString descChecksum)
|
||||||
sameCheckSum key
|
sameCheckSum key
|
||||||
<$> hashFile hash file nullMeterUpdate
|
<$> hashFile hash file nullMeterUpdate
|
||||||
_ -> return True
|
_ -> return True
|
||||||
|
|
|
@ -182,8 +182,8 @@ startRemote addunlockedmatcher r o si file uri sz = do
|
||||||
let file' = joinPath $ map (truncateFilePath pathmax) $
|
let file' = joinPath $ map (truncateFilePath pathmax) $
|
||||||
splitDirectories file
|
splitDirectories file
|
||||||
startingAddUrl si uri o $ do
|
startingAddUrl si uri o $ do
|
||||||
showNote $ "from " ++ Remote.name r
|
showNote $ UnquotedString $ "from " ++ Remote.name r
|
||||||
showDestinationFile file'
|
showDestinationFile (toRawFilePath file')
|
||||||
performRemote addunlockedmatcher r o uri (toRawFilePath file') sz
|
performRemote addunlockedmatcher r o uri (toRawFilePath file') sz
|
||||||
|
|
||||||
performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
|
performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
|
||||||
|
@ -296,7 +296,7 @@ addUrlChecked :: AddUrlOptions -> URLString -> RawFilePath -> UUID -> (Key -> An
|
||||||
addUrlChecked o url file u checkexistssize key =
|
addUrlChecked o url file u checkexistssize key =
|
||||||
ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key))
|
ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key))
|
||||||
( do
|
( do
|
||||||
showDestinationFile (fromRawFilePath file)
|
showDestinationFile file
|
||||||
next $ return True
|
next $ return True
|
||||||
, checkexistssize key >>= \case
|
, checkexistssize key >>= \case
|
||||||
Just (exists, samesize, url')
|
Just (exists, samesize, url')
|
||||||
|
@ -337,7 +337,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
||||||
, normalfinish tmp backend
|
, normalfinish tmp backend
|
||||||
)
|
)
|
||||||
normalfinish tmp backend = checkCanAdd o file $ \canadd -> do
|
normalfinish tmp backend = checkCanAdd o file $ \canadd -> do
|
||||||
showDestinationFile (fromRawFilePath file)
|
showDestinationFile file
|
||||||
createWorkTreeDirectory (parentDir file)
|
createWorkTreeDirectory (parentDir file)
|
||||||
Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file
|
Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file
|
||||||
-- Ask youtube-dl what filename it will download first,
|
-- Ask youtube-dl what filename it will download first,
|
||||||
|
@ -359,7 +359,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
||||||
Right (Just mediafile) -> do
|
Right (Just mediafile) -> do
|
||||||
cleanuptmp
|
cleanuptmp
|
||||||
checkCanAdd o dest $ \canadd -> do
|
checkCanAdd o dest $ \canadd -> do
|
||||||
showDestinationFile (fromRawFilePath dest)
|
showDestinationFile dest
|
||||||
addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile))
|
addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile))
|
||||||
return $ Just mediakey
|
return $ Just mediakey
|
||||||
Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
|
Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
|
||||||
|
@ -409,10 +409,10 @@ startingAddUrl si url o p = starting "addurl" ai si $ do
|
||||||
ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url)))
|
ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url)))
|
||||||
urlkey = Backend.URL.fromUrl url Nothing
|
urlkey = Backend.URL.fromUrl url Nothing
|
||||||
|
|
||||||
showDestinationFile :: FilePath -> Annex ()
|
showDestinationFile :: RawFilePath -> Annex ()
|
||||||
showDestinationFile file = do
|
showDestinationFile file = do
|
||||||
showNote ("to " ++ file)
|
showNote ("to " <> QuotedPath file)
|
||||||
maybeShowJSON $ JSONChunk [("file", file)]
|
maybeShowJSON $ JSONChunk [("file", fromRawFilePath file)]
|
||||||
|
|
||||||
{- The Key should be a dummy key, based on the URL, which is used
|
{- The Key should be a dummy key, based on the URL, which is used
|
||||||
- for this download, before we can examine the file and find its real key.
|
- for this download, before we can examine the file and find its real key.
|
||||||
|
@ -525,7 +525,7 @@ youtubeDlDestFile o destfile mediafile
|
||||||
|
|
||||||
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key)
|
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key)
|
||||||
nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
|
nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
|
||||||
showDestinationFile (fromRawFilePath file)
|
showDestinationFile file
|
||||||
createWorkTreeDirectory (parentDir file)
|
createWorkTreeDirectory (parentDir file)
|
||||||
addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
|
addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
|
||||||
return (Just key)
|
return (Just key)
|
||||||
|
|
|
@ -233,10 +233,10 @@ checkRequiredContent (PreferredContentChecked False) u k afile =
|
||||||
if afile == afile'
|
if afile == afile'
|
||||||
then showLongNote "That file is required content. It cannot be dropped!"
|
then showLongNote "That file is required content. It cannot be dropped!"
|
||||||
else showLongNote $ "That file has the same content as another file"
|
else showLongNote $ "That file has the same content as another file"
|
||||||
++ case afile' of
|
<> case afile' of
|
||||||
AssociatedFile (Just f) -> " (" ++ fromRawFilePath f ++ "),"
|
AssociatedFile (Just f) -> " (" <> QuotedPath f <> "),"
|
||||||
AssociatedFile Nothing -> ""
|
AssociatedFile Nothing -> ""
|
||||||
++ " which is required content. It cannot be dropped!"
|
<> " which is required content. It cannot be dropped!"
|
||||||
showLongNote "(Use --force to override this check, or adjust required content configuration.)"
|
showLongNote "(Use --force to override this check, or adjust required content configuration.)"
|
||||||
return False
|
return False
|
||||||
|
|
||||||
|
|
|
@ -50,7 +50,7 @@ start from numcopies mincopies = startUnused "dropunused"
|
||||||
perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform
|
perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform
|
||||||
perform from numcopies mincopies key = case from of
|
perform from numcopies mincopies key = case from of
|
||||||
Just r -> do
|
Just r -> do
|
||||||
showAction $ "from " ++ Remote.name r
|
showAction $ UnquotedString $ "from " ++ Remote.name r
|
||||||
Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud
|
Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud
|
||||||
Nothing -> ifM (inAnnex key)
|
Nothing -> ifM (inAnnex key)
|
||||||
( droplocal
|
( droplocal
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE OverloadedStrings, CPP #-}
|
||||||
|
|
||||||
module Command.EnableTor where
|
module Command.EnableTor where
|
||||||
|
|
||||||
|
@ -61,7 +61,7 @@ start _os = do
|
||||||
let ps = [Param (cmdname cmd), Param (show curruserid)]
|
let ps = [Param (cmdname cmd), Param (show curruserid)]
|
||||||
sucommand <- liftIO $ mkSuCommand gitannex ps
|
sucommand <- liftIO $ mkSuCommand gitannex ps
|
||||||
cleanenv <- liftIO $ cleanStandaloneEnvironment
|
cleanenv <- liftIO $ cleanStandaloneEnvironment
|
||||||
maybe noop showLongNote
|
maybe noop (showLongNote . UnquotedString)
|
||||||
(describePasswordPrompt' sucommand)
|
(describePasswordPrompt' sucommand)
|
||||||
ifM (liftIO $ runSuCommand sucommand cleanenv)
|
ifM (liftIO $ runSuCommand sucommand cleanenv)
|
||||||
( next checkHiddenService
|
( next checkHiddenService
|
||||||
|
|
|
@ -61,13 +61,13 @@ start (Expire expire) noact actlog descs u =
|
||||||
case lastact of
|
case lastact of
|
||||||
Just ent | notexpired ent -> checktrust (== DeadTrusted) $
|
Just ent | notexpired ent -> checktrust (== DeadTrusted) $
|
||||||
starting "unexpire" ai si $ do
|
starting "unexpire" ai si $ do
|
||||||
showNote =<< whenactive
|
showNote . UnquotedString =<< whenactive
|
||||||
unless noact $
|
unless noact $
|
||||||
trustSet u SemiTrusted
|
trustSet u SemiTrusted
|
||||||
next $ return True
|
next $ return True
|
||||||
_ -> checktrust (/= DeadTrusted) $
|
_ -> checktrust (/= DeadTrusted) $
|
||||||
starting "expire" ai si $ do
|
starting "expire" ai si $ do
|
||||||
showNote =<< whenactive
|
showNote . UnquotedString =<< whenactive
|
||||||
unless noact $
|
unless noact $
|
||||||
trustSet u DeadTrusted
|
trustSet u DeadTrusted
|
||||||
next $ return True
|
next $ return True
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Command.Forget where
|
module Command.Forget where
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
|
|
|
@ -159,15 +159,15 @@ performRemote key afile backend numcopies remote =
|
||||||
dispatch =<< Remote.hasKey remote key
|
dispatch =<< Remote.hasKey remote key
|
||||||
where
|
where
|
||||||
dispatch (Left err) = do
|
dispatch (Left err) = do
|
||||||
showNote err
|
showNote (UnquotedString err)
|
||||||
return False
|
return False
|
||||||
dispatch (Right True) = withtmp $ \tmpfile ->
|
dispatch (Right True) = withtmp $ \tmpfile ->
|
||||||
getfile tmpfile >>= \case
|
getfile tmpfile >>= \case
|
||||||
Nothing -> go True Nothing
|
Nothing -> go True Nothing
|
||||||
Just (Right verification) -> go True (Just (tmpfile, verification))
|
Just (Right verification) -> go True (Just (tmpfile, verification))
|
||||||
Just (Left _) -> do
|
Just (Left _) -> do
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
warning $ actionItemDesc ai
|
||||||
warning $ UnquotedString (decodeBS (actionItemDesc qp ai)) <> ": failed to download file from remote"
|
<> ": failed to download file from remote"
|
||||||
void $ go True Nothing
|
void $ go True Nothing
|
||||||
return False
|
return False
|
||||||
dispatch (Right False) = go False Nothing
|
dispatch (Right False) = go False Nothing
|
||||||
|
@ -350,10 +350,9 @@ verifyLocationLog' key ai present u updatestatus = do
|
||||||
return True
|
return True
|
||||||
(False, True) -> do
|
(False, True) -> do
|
||||||
fix InfoMissing
|
fix InfoMissing
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
||||||
warning $
|
warning $
|
||||||
"** Based on the location log, " <>
|
"** Based on the location log, " <>
|
||||||
QuotedPath (actionItemDesc qp ai) <>
|
actionItemDesc ai <>
|
||||||
"\n** was expected to be present, " <>
|
"\n** was expected to be present, " <>
|
||||||
"but its content is missing."
|
"but its content is missing."
|
||||||
return False
|
return False
|
||||||
|
@ -390,11 +389,10 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
|
||||||
if null missinglocs
|
if null missinglocs
|
||||||
then return True
|
then return True
|
||||||
else do
|
else do
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
||||||
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
|
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
|
||||||
warning $
|
warning $
|
||||||
"** Required content " <>
|
"** Required content " <>
|
||||||
QuotedPath (actionItemDesc qp ai) <>
|
actionItemDesc ai <>
|
||||||
" is missing from these repositories:\n" <>
|
" is missing from these repositories:\n" <>
|
||||||
UnquotedString missingrequired
|
UnquotedString missingrequired
|
||||||
return False
|
return False
|
||||||
|
@ -467,9 +465,7 @@ checkKeySizeOr bad key file ai = case fromKey keySize key of
|
||||||
return same
|
return same
|
||||||
badsize a b = do
|
badsize a b = do
|
||||||
msg <- bad key
|
msg <- bad key
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
warning $ actionItemDesc ai
|
||||||
warning $
|
|
||||||
QuotedPath (actionItemDesc qp ai)
|
|
||||||
<> ": Bad file size ("
|
<> ": Bad file size ("
|
||||||
<> UnquotedString (compareSizes storageUnits True a b)
|
<> UnquotedString (compareSizes storageUnits True a b)
|
||||||
<> "); "
|
<> "); "
|
||||||
|
@ -485,12 +481,10 @@ checkKeyUpgrade :: Backend -> Key -> ActionItem -> AssociatedFile -> Annex Bool
|
||||||
checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
|
checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
|
||||||
case Types.Backend.canUpgradeKey backend of
|
case Types.Backend.canUpgradeKey backend of
|
||||||
Just a | a key -> do
|
Just a | a key -> do
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
warning $ actionItemDesc ai
|
||||||
warning $
|
|
||||||
QuotedPath (actionItemDesc qp ai)
|
|
||||||
<> ": Can be upgraded to an improved key format. "
|
<> ": Can be upgraded to an improved key format. "
|
||||||
<> "You can do so by running: git annex migrate --backend="
|
<> "You can do so by running: git annex migrate --backend="
|
||||||
<> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key)))
|
<> UnquotedByteString (formatKeyVariety (fromKey keyVariety key))
|
||||||
<> " "
|
<> " "
|
||||||
<> QuotedPath file
|
<> QuotedPath file
|
||||||
return True
|
return True
|
||||||
|
@ -537,9 +531,7 @@ checkBackendOr bad backend key file ai =
|
||||||
ok <- verifier key file
|
ok <- verifier key file
|
||||||
unless ok $ do
|
unless ok $ do
|
||||||
msg <- bad key
|
msg <- bad key
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
warning $ actionItemDesc ai
|
||||||
warning $
|
|
||||||
QuotedPath (actionItemDesc qp ai)
|
|
||||||
<> ": Bad file content; "
|
<> ": Bad file content; "
|
||||||
<> UnquotedString msg
|
<> UnquotedString msg
|
||||||
return ok
|
return ok
|
||||||
|
@ -565,9 +557,7 @@ checkInodeCache key content mic ai = case mic of
|
||||||
withTSDelta (liftIO . genInodeCache content) >>= \case
|
withTSDelta (liftIO . genInodeCache content) >>= \case
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
Just ic' -> whenM (compareInodeCaches ic ic') $ do
|
Just ic' -> whenM (compareInodeCaches ic ic') $ do
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
warning $ actionItemDesc ai
|
||||||
warning $
|
|
||||||
QuotedPath (actionItemDesc qp ai)
|
|
||||||
<> ": Stale or missing inode cache; updating."
|
<> ": Stale or missing inode cache; updating."
|
||||||
Database.Keys.addInodeCaches key [ic]
|
Database.Keys.addInodeCaches key [ic]
|
||||||
|
|
||||||
|
|
|
@ -93,7 +93,7 @@ getKey' :: Key -> AssociatedFile -> [Remote] -> Annex Bool
|
||||||
getKey' key afile = dispatch
|
getKey' key afile = dispatch
|
||||||
where
|
where
|
||||||
dispatch [] = do
|
dispatch [] = do
|
||||||
showNote "not available"
|
showNote (UnquotedString "not available")
|
||||||
showlocs []
|
showlocs []
|
||||||
return False
|
return False
|
||||||
dispatch remotes = notifyTransfer Download afile $ \witness -> do
|
dispatch remotes = notifyTransfer Download afile $ \witness -> do
|
||||||
|
@ -116,6 +116,6 @@ getKey' key afile = dispatch
|
||||||
either (const False) id <$> Remote.hasKey r key
|
either (const False) id <$> Remote.hasKey r key
|
||||||
| otherwise = return True
|
| otherwise = return True
|
||||||
docopy r witness = do
|
docopy r witness = do
|
||||||
showAction $ "from " ++ Remote.name r
|
showAction $ UnquotedString $ "from " ++ Remote.name r
|
||||||
logStatusAfter key $
|
logStatusAfter key $
|
||||||
download r key afile stdRetry witness
|
download r key afile stdRetry witness
|
||||||
|
|
|
@ -154,7 +154,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
||||||
si = SeekInput []
|
si = SeekInput []
|
||||||
|
|
||||||
deletedup k = do
|
deletedup k = do
|
||||||
showNote $ "duplicate of " ++ serializeKey k
|
showNote $ UnquotedString $ "duplicate of " ++ serializeKey k
|
||||||
verifyExisting k destfile
|
verifyExisting k destfile
|
||||||
( do
|
( do
|
||||||
liftIO $ R.removeLink srcfile
|
liftIO $ R.removeLink srcfile
|
||||||
|
@ -300,7 +300,9 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
||||||
(reinject k)
|
(reinject k)
|
||||||
(importfile ld k)
|
(importfile ld k)
|
||||||
_ -> importfile ld k
|
_ -> importfile ld k
|
||||||
skipbecause s = showNote (s ++ "; skipping") >> next (return True)
|
skipbecause s = do
|
||||||
|
showNote (s <> "; skipping")
|
||||||
|
next (return True)
|
||||||
|
|
||||||
verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
|
verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
|
||||||
verifyExisting key destfile (yes, no) = do
|
verifyExisting key destfile (yes, no) = do
|
||||||
|
|
|
@ -16,7 +16,6 @@ import Text.Feed.Query
|
||||||
import Text.Feed.Types
|
import Text.Feed.Types
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Char
|
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Time.Format
|
import Data.Time.Format
|
||||||
import Data.Time.Calendar
|
import Data.Time.Calendar
|
||||||
|
@ -95,9 +94,9 @@ getFeed addunlockedmatcher opts cache url = do
|
||||||
go tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case
|
go tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case
|
||||||
Nothing -> debugfeedcontent tmpf "parsing the feed failed"
|
Nothing -> debugfeedcontent tmpf "parsing the feed failed"
|
||||||
Just f -> do
|
Just f -> do
|
||||||
case map sanitizetitle $ decodeBS $ fromFeedText $ getFeedTitle f of
|
case decodeBS $ fromFeedText $ getFeedTitle f of
|
||||||
"" -> noop
|
"" -> noop
|
||||||
t -> showNote ('"' : t ++ "\"")
|
t -> showNote (UnquotedString ('"' : t ++ "\""))
|
||||||
case findDownloads url f of
|
case findDownloads url f of
|
||||||
[] -> debugfeedcontent tmpf "bad feed content; no enclosures to download"
|
[] -> debugfeedcontent tmpf "bad feed content; no enclosures to download"
|
||||||
l -> do
|
l -> do
|
||||||
|
@ -107,9 +106,6 @@ getFeed addunlockedmatcher opts cache url = do
|
||||||
, void $ feedProblem url
|
, void $ feedProblem url
|
||||||
"problem downloading some item(s) from feed"
|
"problem downloading some item(s) from feed"
|
||||||
)
|
)
|
||||||
sanitizetitle c
|
|
||||||
| isControl c = '_'
|
|
||||||
| otherwise = c
|
|
||||||
debugfeedcontent tmpf msg = do
|
debugfeedcontent tmpf msg = do
|
||||||
feedcontent <- liftIO $ readFile tmpf
|
feedcontent <- liftIO $ readFile tmpf
|
||||||
fastDebug "Command.ImportFeed" $ unlines
|
fastDebug "Command.ImportFeed" $ unlines
|
||||||
|
|
|
@ -183,7 +183,7 @@ itemInfo o (si, p) = ifM (isdir (toRawFilePath p))
|
||||||
noInfo :: String -> SeekInput -> String -> Annex ()
|
noInfo :: String -> SeekInput -> String -> Annex ()
|
||||||
noInfo s si msg = do
|
noInfo s si msg = do
|
||||||
showStartMessage (StartMessage "info" (ActionItemOther (Just (UnquotedString s))) si)
|
showStartMessage (StartMessage "info" (ActionItemOther (Just (UnquotedString s))) si)
|
||||||
showNote msg
|
showNote (UnquotedString msg)
|
||||||
showEndFail
|
showEndFail
|
||||||
Annex.incError
|
Annex.incError
|
||||||
|
|
||||||
|
@ -463,7 +463,7 @@ transfer_list = stat desc $ nojson $ lift $ do
|
||||||
desc = "transfers in progress"
|
desc = "transfers in progress"
|
||||||
line qp uuidmap t i = unwords
|
line qp uuidmap t i = unwords
|
||||||
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
|
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
|
||||||
, fromRawFilePath $ actionItemDesc qp $ mkActionItem
|
, fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem
|
||||||
(transferKey t, associatedFile i)
|
(transferKey t, associatedFile i)
|
||||||
, if transferDirection t == Upload then "to" else "from"
|
, if transferDirection t == Upload then "to" else "from"
|
||||||
, maybe (fromUUID $ transferUUID t) Remote.name $
|
, maybe (fromUUID $ transferUUID t) Remote.name $
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Command.Map where
|
module Command.Map where
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
@ -62,11 +64,11 @@ start = startingNoMessage (ActionItemOther Nothing) $ do
|
||||||
|
|
||||||
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
|
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
|
||||||
runViewer file [] = do
|
runViewer file [] = do
|
||||||
showLongNote $ "left map in " ++ file
|
showLongNote $ UnquotedString $ "left map in " ++ file
|
||||||
return True
|
return True
|
||||||
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
|
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
|
||||||
( do
|
( do
|
||||||
showLongNote $ "running: " ++ c ++ unwords (toCommand ps)
|
showLongNote $ UnquotedString $ "running: " ++ c ++ unwords (toCommand ps)
|
||||||
showOutput
|
showOutput
|
||||||
liftIO $ boolSystem c ps
|
liftIO $ boolSystem c ps
|
||||||
, runViewer file rest
|
, runViewer file rest
|
||||||
|
|
|
@ -129,7 +129,7 @@ cleanup k = do
|
||||||
case toJSON' (AddJSONActionItemFields m) of
|
case toJSON' (AddJSONActionItemFields m) of
|
||||||
Object o -> maybeShowJSON $ AesonObject o
|
Object o -> maybeShowJSON $ AesonObject o
|
||||||
_ -> noop
|
_ -> noop
|
||||||
showLongNote $ unlines $ concatMap showmeta $
|
showLongNote $ UnquotedString $ unlines $ concatMap showmeta $
|
||||||
map unwrapmeta (fromMetaData m)
|
map unwrapmeta (fromMetaData m)
|
||||||
return True
|
return True
|
||||||
where
|
where
|
||||||
|
|
|
@ -157,10 +157,10 @@ toPerform' mcontentlock dest removewhen key afile fastcheck isthere = do
|
||||||
srcuuid <- getUUID
|
srcuuid <- getUUID
|
||||||
case isthere of
|
case isthere of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
showNote err
|
showNote (UnquotedString err)
|
||||||
stop
|
stop
|
||||||
Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do
|
Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do
|
||||||
showAction $ "to " ++ Remote.name dest
|
showAction $ UnquotedString $ "to " ++ Remote.name dest
|
||||||
ok <- notifyTransfer Upload afile $
|
ok <- notifyTransfer Upload afile $
|
||||||
upload dest key afile stdRetry
|
upload dest key afile stdRetry
|
||||||
if ok
|
if ok
|
||||||
|
@ -260,7 +260,7 @@ fromPerform src removewhen key afile = do
|
||||||
|
|
||||||
fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform)
|
fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform)
|
||||||
fromPerform' present updatelocationlog src key afile = do
|
fromPerform' present updatelocationlog src key afile = do
|
||||||
showAction $ "from " ++ Remote.name src
|
showAction $ UnquotedString $ "from " ++ Remote.name src
|
||||||
destuuid <- getUUID
|
destuuid <- getUUID
|
||||||
logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy ->
|
logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy ->
|
||||||
if present
|
if present
|
||||||
|
@ -314,7 +314,7 @@ fromDrop src destuuid deststartedwithcopy key afile adjusttocheck =
|
||||||
|
|
||||||
faileddropremote = do
|
faileddropremote = do
|
||||||
showLongNote "(Use --force to override this check, or adjust numcopies.)"
|
showLongNote "(Use --force to override this check, or adjust numcopies.)"
|
||||||
showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."
|
showLongNote $ UnquotedString $ "Content not dropped from " ++ Remote.name src ++ "."
|
||||||
logMoveCleanup deststartedwithcopy
|
logMoveCleanup deststartedwithcopy
|
||||||
next $ return False
|
next $ return False
|
||||||
|
|
||||||
|
@ -394,11 +394,13 @@ fromToPerform src dest removewhen key afile = do
|
||||||
haskey <- Remote.hasKey dest key
|
haskey <- Remote.hasKey dest key
|
||||||
case haskey of
|
case haskey of
|
||||||
Left err -> do
|
Left err -> do
|
||||||
showNote err
|
showNote (UnquotedString err)
|
||||||
stop
|
stop
|
||||||
Right True -> do
|
Right True -> do
|
||||||
showAction $ "from " ++ Remote.name src
|
showAction $ UnquotedString $
|
||||||
showAction $ "to " ++ Remote.name dest
|
"from " ++ Remote.name src
|
||||||
|
showAction $ UnquotedString $
|
||||||
|
"to " ++ Remote.name dest
|
||||||
-- The log may not indicate dest's copy
|
-- The log may not indicate dest's copy
|
||||||
-- yet, so make sure it does.
|
-- yet, so make sure it does.
|
||||||
logChange key (Remote.uuid dest) InfoPresent
|
logChange key (Remote.uuid dest) InfoPresent
|
||||||
|
|
|
@ -72,7 +72,7 @@ changeMetaData k metadata = do
|
||||||
return True
|
return True
|
||||||
|
|
||||||
showMetaDataChange :: MetaData -> Annex ()
|
showMetaDataChange :: MetaData -> Annex ()
|
||||||
showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
|
showMetaDataChange = showLongNote . UnquotedString . unlines . concatMap showmeta . fromMetaData
|
||||||
where
|
where
|
||||||
showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
|
showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
|
||||||
showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v)
|
showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v)
|
||||||
|
|
|
@ -73,7 +73,7 @@ perform a o key url = do
|
||||||
_ -> Remote.claimingUrl url
|
_ -> Remote.claimingUrl url
|
||||||
case needremote of
|
case needremote of
|
||||||
Just nr | nr /= r -> do
|
Just nr | nr /= r -> do
|
||||||
showNote $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r
|
showNote $ UnquotedString $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r
|
||||||
next $ return False
|
next $ return False
|
||||||
_ -> do
|
_ -> do
|
||||||
a r key (setDownloader' url r)
|
a r key (setDownloader' url r)
|
||||||
|
|
|
@ -948,14 +948,14 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go
|
||||||
warncannotupdateexport r mtb exported currb = case mtb of
|
warncannotupdateexport r mtb exported currb = case mtb of
|
||||||
Nothing -> inRepo (Git.Ref.tree currb) >>= \case
|
Nothing -> inRepo (Git.Ref.tree currb) >>= \case
|
||||||
Just currt | not (any (== currt) (exportedTreeishes exported)) ->
|
Just currt | not (any (== currt) (exportedTreeishes exported)) ->
|
||||||
showLongNote $ unwords
|
showLongNote $ UnquotedString $ unwords
|
||||||
[ notupdating
|
[ notupdating
|
||||||
, "to reflect changes to the tree, because export"
|
, "to reflect changes to the tree, because export"
|
||||||
, "tracking is not enabled. "
|
, "tracking is not enabled. "
|
||||||
, "(Set " ++ gitconfig ++ " to enable it.)"
|
, "(Set " ++ gitconfig ++ " to enable it.)"
|
||||||
]
|
]
|
||||||
_ -> noop
|
_ -> noop
|
||||||
Just b -> showLongNote $ unwords
|
Just b -> showLongNote $ UnquotedString $ unwords
|
||||||
[ notupdating
|
[ notupdating
|
||||||
, "because " ++ Git.fromRef b ++ " does not exist."
|
, "because " ++ Git.fromRef b ++ " does not exist."
|
||||||
, "(As configured by " ++ gitconfig ++ ")"
|
, "(As configured by " ++ gitconfig ++ ")"
|
||||||
|
|
|
@ -109,7 +109,8 @@ check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int
|
||||||
check file msg a c = do
|
check file msg a c = do
|
||||||
l <- a
|
l <- a
|
||||||
let unusedlist = number c l
|
let unusedlist = number c l
|
||||||
unless (null l) $ showLongNote $ msg unusedlist
|
unless (null l) $
|
||||||
|
showLongNote $ UnquotedString $ msg unusedlist
|
||||||
updateUnusedLog (toRawFilePath file) (M.fromList unusedlist)
|
updateUnusedLog (toRawFilePath file) (M.fromList unusedlist)
|
||||||
return $ c + length l
|
return $ c + length l
|
||||||
|
|
||||||
|
@ -249,7 +250,7 @@ withKeysReferencedDiffGitRefs refspec a = do
|
||||||
- differ from those referenced in the index. -}
|
- differ from those referenced in the index. -}
|
||||||
withKeysReferencedDiffGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
|
withKeysReferencedDiffGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
|
||||||
withKeysReferencedDiffGitRef a ref = do
|
withKeysReferencedDiffGitRef a ref = do
|
||||||
showAction $ "checking " ++ Git.Ref.describe ref
|
showAction $ UnquotedString $ "checking " ++ Git.Ref.describe ref
|
||||||
withKeysReferencedDiff a
|
withKeysReferencedDiff a
|
||||||
(inRepo $ DiffTree.diffIndex ref)
|
(inRepo $ DiffTree.diffIndex ref)
|
||||||
DiffTree.srcsha
|
DiffTree.srcsha
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Command.VAdd where
|
module Command.VAdd where
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Command.VCycle where
|
module Command.VCycle where
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
|
|
|
@ -120,7 +120,7 @@ checkoutViewBranch view madj mkbranch = do
|
||||||
forM_ l (removeemptydir top)
|
forM_ l (removeemptydir top)
|
||||||
liftIO $ void cleanup
|
liftIO $ void cleanup
|
||||||
unlessM (liftIO $ doesDirectoryExist here) $ do
|
unlessM (liftIO $ doesDirectoryExist here) $ do
|
||||||
showLongNote (cwdmissing (fromRawFilePath top))
|
showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top)
|
||||||
return ok
|
return ok
|
||||||
where
|
where
|
||||||
removeemptydir top d = do
|
removeemptydir top d = do
|
||||||
|
|
|
@ -87,12 +87,14 @@ perform o remotemap key ai = do
|
||||||
case formatOption o of
|
case formatOption o of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
let num = length safelocations
|
let num = length safelocations
|
||||||
showNote $ show num ++ " " ++ copiesplural num
|
showNote $ UnquotedString $ show num ++ " " ++ copiesplural num
|
||||||
pp <- ppwhereis "whereis" safelocations urls
|
pp <- ppwhereis "whereis" safelocations urls
|
||||||
unless (null safelocations) $ showLongNote pp
|
unless (null safelocations) $
|
||||||
|
showLongNote (UnquotedString pp)
|
||||||
pp' <- ppwhereis "untrusted" untrustedlocations urls
|
pp' <- ppwhereis "untrusted" untrustedlocations urls
|
||||||
unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
|
unless (null untrustedlocations) $
|
||||||
|
showLongNote $ UnquotedString $
|
||||||
|
untrustedheader ++ pp'
|
||||||
mapM_ (showRemoteUrls remotemap) urls
|
mapM_ (showRemoteUrls remotemap) urls
|
||||||
Just formatter -> liftIO $ do
|
Just formatter -> liftIO $ do
|
||||||
let vs = Command.Find.formatVars key
|
let vs = Command.Find.formatVars key
|
||||||
|
@ -160,6 +162,6 @@ showRemoteUrls :: M.Map UUID Remote -> (UUID, [URLString]) -> Annex ()
|
||||||
showRemoteUrls remotemap (uu, us)
|
showRemoteUrls remotemap (uu, us)
|
||||||
| null us = noop
|
| null us = noop
|
||||||
| otherwise = case M.lookup uu remotemap of
|
| otherwise = case M.lookup uu remotemap of
|
||||||
Just r -> showLongNote $
|
Just r -> showLongNote $ UnquotedString $
|
||||||
unlines $ map (\u -> name r ++ ": " ++ u) us
|
unlines $ map (\u -> name r ++ ": " ++ u) us
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
|
|
2
Creds.hs
2
Creds.hs
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Creds (
|
module Creds (
|
||||||
module Types.Creds,
|
module Types.Creds,
|
||||||
CredPairStorage(..),
|
CredPairStorage(..),
|
||||||
|
|
|
@ -30,13 +30,12 @@ module Git.FilePath (
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
import Git
|
import Git
|
||||||
import qualified Git.Filename as Filename
|
import Git.Filename
|
||||||
|
|
||||||
import qualified System.FilePath.ByteString as P
|
import qualified System.FilePath.ByteString as P
|
||||||
import qualified System.FilePath.Posix.ByteString
|
import qualified System.FilePath.Posix.ByteString
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import qualified Data.ByteString as S
|
|
||||||
|
|
||||||
{- A RawFilePath, relative to the top of the git repository. -}
|
{- A RawFilePath, relative to the top of the git repository. -}
|
||||||
newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
|
newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
|
||||||
|
@ -49,9 +48,9 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
{- Git uses the branch:file form to refer to a BranchFilePath -}
|
{- Git uses the branch:file form to refer to a BranchFilePath -}
|
||||||
descBranchFilePath :: Filename.QuotePath -> BranchFilePath -> S.ByteString
|
descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath
|
||||||
descBranchFilePath qp (BranchFilePath b f) =
|
descBranchFilePath (BranchFilePath b f) =
|
||||||
fromRef' b <> ":" <> Filename.quote qp (getTopFilePath f)
|
UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f)
|
||||||
|
|
||||||
{- Path to a TopFilePath, within the provided git repo. -}
|
{- Path to a TopFilePath, within the provided git repo. -}
|
||||||
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
|
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
|
||||||
|
|
|
@ -76,6 +76,7 @@ instance Quoteable RawFilePath where
|
||||||
-- Eg: QuotedPath f <> ": not found"
|
-- Eg: QuotedPath f <> ": not found"
|
||||||
data StringContainingQuotedPath
|
data StringContainingQuotedPath
|
||||||
= UnquotedString String
|
= UnquotedString String
|
||||||
|
| UnquotedByteString S.ByteString
|
||||||
| QuotedPath RawFilePath
|
| QuotedPath RawFilePath
|
||||||
| StringContainingQuotedPath :+: StringContainingQuotedPath
|
| StringContainingQuotedPath :+: StringContainingQuotedPath
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
@ -88,10 +89,12 @@ quotedPaths (p:ps) = QuotedPath p <> if null ps
|
||||||
|
|
||||||
instance Quoteable StringContainingQuotedPath where
|
instance Quoteable StringContainingQuotedPath where
|
||||||
quote _ (UnquotedString s) = safeOutput (encodeBS s)
|
quote _ (UnquotedString s) = safeOutput (encodeBS s)
|
||||||
|
quote _ (UnquotedByteString s) = safeOutput s
|
||||||
quote qp (QuotedPath p) = quote qp p
|
quote qp (QuotedPath p) = quote qp p
|
||||||
quote qp (a :+: b) = quote qp a <> quote qp b
|
quote qp (a :+: b) = quote qp a <> quote qp b
|
||||||
|
|
||||||
noquote (UnquotedString s) = encodeBS s
|
noquote (UnquotedString s) = encodeBS s
|
||||||
|
noquote (UnquotedByteString s) = s
|
||||||
noquote (QuotedPath p) = p
|
noquote (QuotedPath p) = p
|
||||||
noquote (a :+: b) = noquote a <> noquote b
|
noquote (a :+: b) = noquote a <> noquote b
|
||||||
|
|
||||||
|
@ -100,10 +103,11 @@ instance IsString StringContainingQuotedPath where
|
||||||
|
|
||||||
instance Sem.Semigroup StringContainingQuotedPath where
|
instance Sem.Semigroup StringContainingQuotedPath where
|
||||||
UnquotedString a <> UnquotedString b = UnquotedString (a <> b)
|
UnquotedString a <> UnquotedString b = UnquotedString (a <> b)
|
||||||
|
UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b)
|
||||||
a <> b = a :+: b
|
a <> b = a :+: b
|
||||||
|
|
||||||
instance Monoid StringContainingQuotedPath where
|
instance Monoid StringContainingQuotedPath where
|
||||||
mempty = UnquotedString mempty
|
mempty = UnquotedByteString mempty
|
||||||
|
|
||||||
-- Encoding and then decoding roundtrips only when the string does not
|
-- Encoding and then decoding roundtrips only when the string does not
|
||||||
-- contain high unicode, because eg, both "\12345" and "\227\128\185"
|
-- contain high unicode, because eg, both "\12345" and "\227\128\185"
|
||||||
|
|
|
@ -36,7 +36,7 @@ describeTransfer :: Git.Filename.QuotePath -> Transfer -> TransferInfo -> String
|
||||||
describeTransfer qp t info = unwords
|
describeTransfer qp t info = unwords
|
||||||
[ show $ transferDirection t
|
[ show $ transferDirection t
|
||||||
, show $ transferUUID t
|
, show $ transferUUID t
|
||||||
, decodeBS $ actionItemDesc qp $ ActionItemAssociatedFile
|
, decodeBS $ quote qp $ actionItemDesc $ ActionItemAssociatedFile
|
||||||
(associatedFile info)
|
(associatedFile info)
|
||||||
(transferKey t)
|
(transferKey t)
|
||||||
, show $ bytesComplete info
|
, show $ bytesComplete info
|
||||||
|
|
52
Messages.hs
52
Messages.hs
|
@ -65,6 +65,8 @@ import Messages.Internal
|
||||||
import Messages.Concurrent
|
import Messages.Concurrent
|
||||||
import Annex.Debug
|
import Annex.Debug
|
||||||
import Annex.Concurrent.Utility
|
import Annex.Concurrent.Utility
|
||||||
|
import Utility.SafeOutput
|
||||||
|
import Git.Filename
|
||||||
import qualified Messages.JSON as JSON
|
import qualified Messages.JSON as JSON
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
|
||||||
|
@ -90,15 +92,13 @@ showStartMessage (CustomOutput _) =
|
||||||
_ -> noop
|
_ -> noop
|
||||||
|
|
||||||
showStartActionItem :: String -> ActionItem -> SeekInput -> Annex ()
|
showStartActionItem :: String -> ActionItem -> SeekInput -> Annex ()
|
||||||
showStartActionItem command ai si = do
|
showStartActionItem command ai si = outputMessage json id $
|
||||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
UnquotedString command <> " " <> actionItemDesc ai <> " "
|
||||||
outputMessage json $
|
|
||||||
encodeBS command <> " " <> actionItemDesc qp ai <> " "
|
|
||||||
where
|
where
|
||||||
json = JSON.start command (actionItemFile ai) (actionItemKey ai) si
|
json = JSON.start command (actionItemFile ai) (actionItemKey ai) si
|
||||||
|
|
||||||
showStartNothing :: String -> SeekInput -> Annex ()
|
showStartNothing :: String -> SeekInput -> Annex ()
|
||||||
showStartNothing command si = outputMessage json $ encodeBS $
|
showStartNothing command si = outputMessage json id $ UnquotedString $
|
||||||
command ++ " "
|
command ++ " "
|
||||||
where
|
where
|
||||||
json = JSON.start command Nothing Nothing si
|
json = JSON.start command Nothing Nothing si
|
||||||
|
@ -110,13 +110,13 @@ showEndMessage (StartUsualMessages _ _ _) = showEndResult
|
||||||
showEndMessage (StartNoMessage _) = const noop
|
showEndMessage (StartNoMessage _) = const noop
|
||||||
showEndMessage (CustomOutput _) = const noop
|
showEndMessage (CustomOutput _) = const noop
|
||||||
|
|
||||||
showNote :: String -> Annex ()
|
showNote :: StringContainingQuotedPath -> Annex ()
|
||||||
showNote s = outputMessage (JSON.note s) $ encodeBS $ "(" ++ s ++ ") "
|
showNote s = outputMessage (JSON.note (decodeBS (noquote s))) id $ "(" <> s <> ") "
|
||||||
|
|
||||||
showAction :: String -> Annex ()
|
showAction :: StringContainingQuotedPath -> Annex ()
|
||||||
showAction s = showNote $ s ++ "..."
|
showAction s = showNote $ s <> "..."
|
||||||
|
|
||||||
showSideAction :: String -> Annex ()
|
showSideAction :: StringContainingQuotedPath -> Annex ()
|
||||||
showSideAction m = Annex.getState Annex.output >>= go
|
showSideAction m = Annex.getState Annex.output >>= go
|
||||||
where
|
where
|
||||||
go st
|
go st
|
||||||
|
@ -126,7 +126,7 @@ showSideAction m = Annex.getState Annex.output >>= go
|
||||||
Annex.changeState $ \s -> s { Annex.output = st' }
|
Annex.changeState $ \s -> s { Annex.output = st' }
|
||||||
| sideActionBlock st == InBlock = return ()
|
| sideActionBlock st == InBlock = return ()
|
||||||
| otherwise = go'
|
| otherwise = go'
|
||||||
go' = outputMessage JSON.none $ encodeBS $ "(" ++ m ++ "...)\n"
|
go' = outputMessage JSON.none id $ "(" <> m <> "...)\n"
|
||||||
|
|
||||||
showStoringStateAction :: Annex ()
|
showStoringStateAction :: Annex ()
|
||||||
showStoringStateAction = showSideAction "recording state in git"
|
showStoringStateAction = showSideAction "recording state in git"
|
||||||
|
@ -167,19 +167,18 @@ doQuietAction = bracket setup cleanup . const
|
||||||
{- Make way for subsequent output of a command. -}
|
{- Make way for subsequent output of a command. -}
|
||||||
showOutput :: Annex ()
|
showOutput :: Annex ()
|
||||||
showOutput = unlessM commandProgressDisabled $
|
showOutput = unlessM commandProgressDisabled $
|
||||||
outputMessage JSON.none "\n"
|
outputMessage JSON.none id "\n"
|
||||||
|
|
||||||
showLongNote :: String -> Annex ()
|
showLongNote :: StringContainingQuotedPath -> Annex ()
|
||||||
showLongNote s = outputMessage (JSON.note s) (formatLongNote (encodeBS s))
|
showLongNote s = outputMessage (JSON.note (decodeBS (noquote s))) formatLongNote s
|
||||||
|
|
||||||
formatLongNote :: S.ByteString -> S.ByteString
|
formatLongNote :: S.ByteString -> S.ByteString
|
||||||
formatLongNote s = "\n" <> indent s <> "\n"
|
formatLongNote s = "\n" <> indent s <> "\n"
|
||||||
|
|
||||||
-- Used by external special remote, displayed same as showLongNote
|
-- Used by external special remote, displayed same as showLongNote
|
||||||
-- to console, but json object containing the info is emitted immediately.
|
-- to console, but json object containing the info is emitted immediately.
|
||||||
showInfo :: String -> Annex ()
|
showInfo :: StringContainingQuotedPath -> Annex ()
|
||||||
showInfo s = outputMessage' outputJSON (JSON.info s) $
|
showInfo s = outputMessage' outputJSON (JSON.info (decodeBS (noquote s))) formatLongNote s
|
||||||
formatLongNote (encodeBS s)
|
|
||||||
|
|
||||||
showEndOk :: Annex ()
|
showEndOk :: Annex ()
|
||||||
showEndOk = showEndResult True
|
showEndOk = showEndResult True
|
||||||
|
@ -188,7 +187,8 @@ showEndFail :: Annex ()
|
||||||
showEndFail = showEndResult False
|
showEndFail = showEndResult False
|
||||||
|
|
||||||
showEndResult :: Bool -> Annex ()
|
showEndResult :: Bool -> Annex ()
|
||||||
showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n"
|
showEndResult ok = outputMessage (JSON.end ok) id $
|
||||||
|
UnquotedByteString (endResult ok) <> "\n"
|
||||||
|
|
||||||
endResult :: Bool -> S.ByteString
|
endResult :: Bool -> S.ByteString
|
||||||
endResult True = "ok"
|
endResult True = "ok"
|
||||||
|
@ -206,7 +206,7 @@ earlyWarning = warning' False id
|
||||||
warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
||||||
warning' makeway consolewhitespacef w = do
|
warning' makeway consolewhitespacef w = do
|
||||||
when makeway $
|
when makeway $
|
||||||
outputMessage JSON.none "\n"
|
outputMessage JSON.none id "\n"
|
||||||
outputError consolewhitespacef (w <> "\n")
|
outputError consolewhitespacef (w <> "\n")
|
||||||
|
|
||||||
{- Not concurrent output safe. -}
|
{- Not concurrent output safe. -}
|
||||||
|
@ -214,7 +214,7 @@ warningIO :: String -> IO ()
|
||||||
warningIO w = do
|
warningIO w = do
|
||||||
putStr "\n"
|
putStr "\n"
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
hPutStrLn stderr w
|
hPutStrLn stderr (safeOutput w)
|
||||||
|
|
||||||
indent :: S.ByteString -> S.ByteString
|
indent :: S.ByteString -> S.ByteString
|
||||||
indent = S.intercalate "\n" . map (" " <>) . S8.lines
|
indent = S.intercalate "\n" . map (" " <>) . S8.lines
|
||||||
|
@ -230,19 +230,19 @@ showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)
|
||||||
{- Performs an action that outputs nonstandard/customized output, and
|
{- Performs an action that outputs nonstandard/customized output, and
|
||||||
- in JSON mode wraps its output in JSON.start and JSON.end, so it's
|
- in JSON mode wraps its output in JSON.start and JSON.end, so it's
|
||||||
- a complete JSON document.
|
- a complete JSON document.
|
||||||
- This is only needed when showStart* and showEndOk is not used.
|
- This is only needed when showStartMessage and showEndOk is not used.
|
||||||
-}
|
-}
|
||||||
showCustom :: String -> SeekInput -> Annex Bool -> Annex ()
|
showCustom :: String -> SeekInput -> Annex Bool -> Annex ()
|
||||||
showCustom command si a = do
|
showCustom command si a = do
|
||||||
outputMessage (JSON.start command Nothing Nothing si) ""
|
outputMessage (JSON.start command Nothing Nothing si) id ""
|
||||||
r <- a
|
r <- a
|
||||||
outputMessage (JSON.end r) ""
|
outputMessage (JSON.end r) id ""
|
||||||
|
|
||||||
showHeader :: S.ByteString -> Annex ()
|
showHeader :: S.ByteString -> Annex ()
|
||||||
showHeader h = outputMessage JSON.none (h <> ": ")
|
showHeader h = outputMessage JSON.none id (UnquotedByteString h <> ": ")
|
||||||
|
|
||||||
showRaw :: S.ByteString -> Annex ()
|
showRaw :: S.ByteString -> Annex ()
|
||||||
showRaw s = outputMessage JSON.none (s <> "\n")
|
showRaw s = outputMessage JSON.none id (UnquotedByteString s <> "\n")
|
||||||
|
|
||||||
setupConsole :: IO ()
|
setupConsole :: IO ()
|
||||||
setupConsole = do
|
setupConsole = do
|
||||||
|
@ -267,7 +267,7 @@ debugDisplayer = do
|
||||||
-- that are displayed at the same time from mixing together.
|
-- that are displayed at the same time from mixing together.
|
||||||
lock <- newMVar ()
|
lock <- newMVar ()
|
||||||
return $ \s -> withMVar lock $ \() -> do
|
return $ \s -> withMVar lock $ \() -> do
|
||||||
S.hPutStr stderr (s <> "\n")
|
S.hPutStr stderr (safeOutput s <> "\n")
|
||||||
hFlush stderr
|
hFlush stderr
|
||||||
|
|
||||||
{- Should commands that normally output progress messages have that
|
{- Should commands that normally output progress messages have that
|
||||||
|
|
|
@ -21,22 +21,25 @@ import qualified Data.ByteString as S
|
||||||
withMessageState :: (MessageState -> Annex a) -> Annex a
|
withMessageState :: (MessageState -> Annex a) -> Annex a
|
||||||
withMessageState a = Annex.getState Annex.output >>= a
|
withMessageState a = Annex.getState Annex.output >>= a
|
||||||
|
|
||||||
outputMessage :: JSONBuilder -> S.ByteString -> Annex ()
|
outputMessage :: JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
||||||
outputMessage = outputMessage' bufferJSON
|
outputMessage = outputMessage' bufferJSON
|
||||||
|
|
||||||
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex ()
|
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
||||||
outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of
|
outputMessage' jsonoutputter jsonbuilder consolewhitespacef msg = withMessageState $ \s -> case outputType s of
|
||||||
NormalOutput
|
NormalOutput
|
||||||
| concurrentOutputEnabled s -> do
|
| concurrentOutputEnabled s -> do
|
||||||
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||||
liftIO $ clearProgressMeter s
|
liftIO $ clearProgressMeter s
|
||||||
concurrentMessage s False (decodeBS msg) q
|
concurrentMessage s False (decodeBS (consolewhitespacef (quote qp msg))) q
|
||||||
| otherwise -> do
|
| otherwise -> do
|
||||||
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||||
liftIO $ clearProgressMeter s
|
liftIO $ clearProgressMeter s
|
||||||
liftIO $ flushed $ S.putStr msg
|
liftIO $ flushed $ S.putStr (consolewhitespacef (quote qp msg))
|
||||||
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
|
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
|
||||||
QuietOutput -> q
|
QuietOutput -> q
|
||||||
SerializedOutput h _ -> do
|
SerializedOutput h _ -> do
|
||||||
liftIO $ outputSerialized h $ OutputMessage msg
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||||
|
liftIO $ outputSerialized h $ OutputMessage $ consolewhitespacef $ quote qp msg
|
||||||
void $ jsonoutputter jsonbuilder s
|
void $ jsonoutputter jsonbuilder s
|
||||||
|
|
||||||
-- Buffer changes to JSON until end is reached and then emit it.
|
-- Buffer changes to JSON until end is reached and then emit it.
|
||||||
|
|
|
@ -177,7 +177,7 @@ meteredFile file combinemeterupdate key a =
|
||||||
|
|
||||||
{- Progress dots. -}
|
{- Progress dots. -}
|
||||||
showProgressDots :: Annex ()
|
showProgressDots :: Annex ()
|
||||||
showProgressDots = outputMessage JSON.none "."
|
showProgressDots = outputMessage JSON.none id "."
|
||||||
|
|
||||||
{- Runs a command, that may output progress to either stdout or
|
{- Runs a command, that may output progress to either stdout or
|
||||||
- stderr, as well as other messages.
|
- stderr, as well as other messages.
|
||||||
|
|
|
@ -52,7 +52,8 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing
|
||||||
runannex $ outputMessage'
|
runannex $ outputMessage'
|
||||||
(\_ _ -> return False)
|
(\_ _ -> return False)
|
||||||
id
|
id
|
||||||
msg
|
id
|
||||||
|
(UnquotedByteString msg)
|
||||||
loop st
|
loop st
|
||||||
Left (OutputError msg) -> do
|
Left (OutputError msg) -> do
|
||||||
runannex $ outputError id $ UnquotedString msg
|
runannex $ outputError id $ UnquotedString msg
|
||||||
|
|
|
@ -365,13 +365,13 @@ showLocations separateuntrusted key exclude nolocmsg = do
|
||||||
"Maybe add some of these git remotes (git remote add ...)"
|
"Maybe add some of these git remotes (git remote add ...)"
|
||||||
ppuuidsskipped <- pp "skipped" uuidsskipped
|
ppuuidsskipped <- pp "skipped" uuidsskipped
|
||||||
"Also these untrusted repositories may contain the file"
|
"Also these untrusted repositories may contain the file"
|
||||||
showLongNote $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of
|
showLongNote $ UnquotedString $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of
|
||||||
[] -> nolocmsg
|
[] -> nolocmsg
|
||||||
s -> s
|
s -> s
|
||||||
)
|
)
|
||||||
ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes
|
ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes
|
||||||
unless (null ignored) $
|
unless (null ignored) $
|
||||||
showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
|
showLongNote $ UnquotedString $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
|
||||||
where
|
where
|
||||||
filteruuids l x = filter (`notElem` x) l
|
filteruuids l x = filter (`notElem` x) l
|
||||||
|
|
||||||
|
@ -383,7 +383,7 @@ showLocations separateuntrusted key exclude nolocmsg = do
|
||||||
showTriedRemotes :: [Remote] -> Annex ()
|
showTriedRemotes :: [Remote] -> Annex ()
|
||||||
showTriedRemotes [] = noop
|
showTriedRemotes [] = noop
|
||||||
showTriedRemotes remotes =
|
showTriedRemotes remotes =
|
||||||
showLongNote $ "Unable to access these remotes: "
|
showLongNote $ UnquotedString $ "Unable to access these remotes: "
|
||||||
++ listRemoteNames remotes
|
++ listRemoteNames remotes
|
||||||
|
|
||||||
listRemoteNames :: [Remote] -> String
|
listRemoteNames :: [Remote] -> String
|
||||||
|
|
|
@ -504,7 +504,7 @@ handleRequest' st external req mp responsehandler
|
||||||
mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix
|
mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix
|
||||||
send (VALUE "") -- end of list
|
send (VALUE "") -- end of list
|
||||||
handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg
|
handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg
|
||||||
handleRemoteRequest (INFO msg) = showInfo msg
|
handleRemoteRequest (INFO msg) = showInfo (UnquotedString msg)
|
||||||
handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"
|
handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"
|
||||||
|
|
||||||
handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err
|
handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err
|
||||||
|
|
|
@ -193,9 +193,9 @@ encryptionSetup c gc = do
|
||||||
Left _ -> True
|
Left _ -> True
|
||||||
encsetup a = use "encryption setup" . a =<< highRandomQuality
|
encsetup a = use "encryption setup" . a =<< highRandomQuality
|
||||||
use m a = do
|
use m a = do
|
||||||
showNote m
|
showNote (UnquotedString m)
|
||||||
cipher <- liftIO a
|
cipher <- liftIO a
|
||||||
showNote (describeCipher cipher)
|
showNote (UnquotedString (describeCipher cipher))
|
||||||
return (storeCipher cipher c', EncryptionIsSetup)
|
return (storeCipher cipher c', EncryptionIsSetup)
|
||||||
highRandomQuality = ifM (Annex.getRead Annex.fast)
|
highRandomQuality = ifM (Annex.getRead Annex.fast)
|
||||||
( return False
|
( return False
|
||||||
|
|
|
@ -29,4 +29,4 @@ cantCheck :: Describable a => a -> e
|
||||||
cantCheck v = giveup $ "unable to check " ++ describe v
|
cantCheck v = giveup $ "unable to check " ++ describe v
|
||||||
|
|
||||||
showLocking :: Describable a => a -> Annex ()
|
showLocking :: Describable a => a -> Annex ()
|
||||||
showLocking v = showAction $ "locking " ++ describe v
|
showLocking v = showAction $ UnquotedString $ "locking " ++ describe v
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.Helper.Ssh where
|
module Remote.Helper.Ssh where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP, OverloadedStrings #-}
|
||||||
|
|
||||||
module Remote.Rsync (
|
module Remote.Rsync (
|
||||||
remote,
|
remote,
|
||||||
|
|
|
@ -774,7 +774,7 @@ genBucket c gc u = do
|
||||||
case r of
|
case r of
|
||||||
Right True -> noop
|
Right True -> noop
|
||||||
_ -> do
|
_ -> do
|
||||||
showAction $ "creating bucket in " ++ datacenter
|
showAction $ UnquotedString $ "creating bucket in " ++ datacenter
|
||||||
void $ liftIO $ runResourceT $ sendS3Handle h $
|
void $ liftIO $ runResourceT $ sendS3Handle h $
|
||||||
(S3.putBucket (bucket info))
|
(S3.putBucket (bucket info))
|
||||||
{ S3.pbCannedAcl = acl info
|
{ S3.pbCannedAcl = acl info
|
||||||
|
|
|
@ -9,24 +9,22 @@
|
||||||
|
|
||||||
module Types.ActionItem (
|
module Types.ActionItem (
|
||||||
module Types.ActionItem,
|
module Types.ActionItem,
|
||||||
Git.Filename.StringContainingQuotedPath(..),
|
StringContainingQuotedPath(..),
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Key
|
import Key
|
||||||
import Types.Transfer
|
import Types.Transfer
|
||||||
import Git.FilePath
|
import Git.FilePath
|
||||||
import qualified Git.Filename
|
import Git.Filename (StringContainingQuotedPath(..))
|
||||||
import Utility.FileSystemEncoding
|
import Utility.FileSystemEncoding
|
||||||
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
|
|
||||||
data ActionItem
|
data ActionItem
|
||||||
= ActionItemAssociatedFile AssociatedFile Key
|
= ActionItemAssociatedFile AssociatedFile Key
|
||||||
| ActionItemKey Key
|
| ActionItemKey Key
|
||||||
| ActionItemBranchFilePath BranchFilePath Key
|
| ActionItemBranchFilePath BranchFilePath Key
|
||||||
| ActionItemFailedTransfer Transfer TransferInfo
|
| ActionItemFailedTransfer Transfer TransferInfo
|
||||||
| ActionItemTreeFile RawFilePath
|
| ActionItemTreeFile RawFilePath
|
||||||
| ActionItemOther (Maybe Git.Filename.StringContainingQuotedPath)
|
| ActionItemOther (Maybe StringContainingQuotedPath)
|
||||||
-- Use to avoid more than one thread concurrently processing the
|
-- Use to avoid more than one thread concurrently processing the
|
||||||
-- same Key.
|
-- same Key.
|
||||||
| OnlyActionOn Key ActionItem
|
| OnlyActionOn Key ActionItem
|
||||||
|
@ -59,19 +57,21 @@ instance MkActionItem (BranchFilePath, Key) where
|
||||||
instance MkActionItem (Transfer, TransferInfo) where
|
instance MkActionItem (Transfer, TransferInfo) where
|
||||||
mkActionItem = uncurry ActionItemFailedTransfer
|
mkActionItem = uncurry ActionItemFailedTransfer
|
||||||
|
|
||||||
actionItemDesc :: Git.Filename.QuotePath -> ActionItem -> S.ByteString
|
actionItemDesc :: ActionItem -> StringContainingQuotedPath
|
||||||
actionItemDesc qp (ActionItemAssociatedFile (AssociatedFile (Just f)) _) =
|
actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) =
|
||||||
Git.Filename.quote qp f
|
QuotedPath f
|
||||||
actionItemDesc _ (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
|
actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
|
||||||
serializeKey' k
|
UnquotedByteString (serializeKey' k)
|
||||||
actionItemDesc _ (ActionItemKey k) = serializeKey' k
|
actionItemDesc (ActionItemKey k) =
|
||||||
actionItemDesc qp (ActionItemBranchFilePath bfp _) = descBranchFilePath qp bfp
|
UnquotedByteString (serializeKey' k)
|
||||||
actionItemDesc qp (ActionItemFailedTransfer t i) = actionItemDesc qp $
|
actionItemDesc (ActionItemBranchFilePath bfp _) =
|
||||||
|
descBranchFilePath bfp
|
||||||
|
actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
|
||||||
ActionItemAssociatedFile (associatedFile i) (transferKey t)
|
ActionItemAssociatedFile (associatedFile i) (transferKey t)
|
||||||
actionItemDesc qp (ActionItemTreeFile f) = Git.Filename.quote qp f
|
actionItemDesc (ActionItemTreeFile f) = QuotedPath f
|
||||||
actionItemDesc _ (ActionItemOther Nothing) = mempty
|
actionItemDesc (ActionItemOther Nothing) = mempty
|
||||||
actionItemDesc qp (ActionItemOther (Just v)) = Git.Filename.quote qp v
|
actionItemDesc (ActionItemOther (Just v)) = v
|
||||||
actionItemDesc qp (OnlyActionOn _ ai) = actionItemDesc qp ai
|
actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
|
||||||
|
|
||||||
actionItemKey :: ActionItem -> Maybe Key
|
actionItemKey :: ActionItem -> Maybe Key
|
||||||
actionItemKey (ActionItemAssociatedFile _ k) = Just k
|
actionItemKey (ActionItemAssociatedFile _ k) = Just k
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V0 where
|
module Upgrade.V0 where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V1 where
|
module Upgrade.V1 where
|
||||||
|
|
||||||
import System.Posix.Types
|
import System.Posix.Types
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V2 where
|
module Upgrade.V2 where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
@ -120,7 +122,7 @@ push = do
|
||||||
-- no origin exists, so just let the user
|
-- no origin exists, so just let the user
|
||||||
-- know about the new branch
|
-- know about the new branch
|
||||||
void Annex.Branch.update
|
void Annex.Branch.update
|
||||||
showLongNote $
|
showLongNote $ UnquotedString $
|
||||||
"git-annex branch created\n" ++
|
"git-annex branch created\n" ++
|
||||||
"Be sure to push this branch when pushing to remotes.\n"
|
"Be sure to push this branch when pushing to remotes.\n"
|
||||||
|
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V6 where
|
module Upgrade.V6 where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V8 where
|
module Upgrade.V8 where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
- Licensed under the GNU AGPL version 3 or higher.
|
- Licensed under the GNU AGPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Upgrade.V9 where
|
module Upgrade.V9 where
|
||||||
|
|
||||||
import Annex.Common
|
import Annex.Common
|
||||||
|
|
|
@ -33,10 +33,13 @@ behave more like git.
|
||||||
> (by default it does), so once this gets implemented, some users may want
|
> (by default it does), so once this gets implemented, some users may want
|
||||||
> to set that config to false. --[[Joey]]
|
> to set that config to false. --[[Joey]]
|
||||||
|
|
||||||
> Update: Most git-annex commands now quote filenames, due to work on
|
> Update: Messages now handles quoting of filenames, and also filtering
|
||||||
> ActionItem display. `git-annex find`, `git-annex info $file`,
|
> out any escape sequences in other things that get displayed (like Keys..)
|
||||||
> and everywhere filenames get
|
>
|
||||||
> embedded in info messages still need to be done.
|
> Still need to deal with `git-annex find` and `git-annex info $file`
|
||||||
|
> and anything else that outputs without using Messages.
|
||||||
|
> (Eg need to do `git-annex metadata`, `git-annex config --get` and `git-annex schedule` and `git-annex wanted`
|
||||||
|
> and `git-annex required` and `git-annex group`)
|
||||||
|
|
||||||
----
|
----
|
||||||
|
|
||||||
|
@ -46,14 +49,6 @@ extension of a SHA-E key. So commands like `git-annex lookupkey`
|
||||||
and `git-annex find` that output keys might need to handle
|
and `git-annex find` that output keys might need to handle
|
||||||
that, when outputting to a terminal?
|
that, when outputting to a terminal?
|
||||||
|
|
||||||
Also:
|
|
||||||
`git-annex metadata` could also contain an escape sequence. So could
|
|
||||||
`git-annex config --get` and `git-annex schedule` and `git-annex wanted`
|
|
||||||
and `git-annex required` and `git-annex group`. And so could the
|
|
||||||
description of a repository. It seems that git-annex could just filter out
|
|
||||||
control characters from all of these, since they are not filenames, and
|
|
||||||
any control characters in them are surely malicious.
|
|
||||||
|
|
||||||
Also: git-annex initremote with autoenable may be able to cause a remote
|
Also: git-annex initremote with autoenable may be able to cause a remote
|
||||||
with a malicious name to be set up?
|
with a malicious name to be set up?
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue