mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

filter out control characters in warning messages

Browse source 
Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.

Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.

When json is being output, no quoting is done, since json gets its own
quoting.

This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.

Sponsored-by: Brett Eisenberg on Patreon
This commit is contained in:
Joey Hess 2023-04-10 14:47:32 -04:00
parent 007e302637
commit 3290a09a70
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
75 changed files with 259 additions and 229 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Annex/Action.hs
View file

@ -37,14 +37,14 @@ action :: Annex () -> Annex Bool
action a = tryNonAsync a >>= \case action a = tryNonAsync a >>= \case
Right () -> return True Right () -> return True
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return False return False
verifiedAction :: Annex Verification -> Annex (Bool, Verification) verifiedAction :: Annex Verification -> Annex (Bool, Verification)
verifiedAction a = tryNonAsync a >>= \case verifiedAction a = tryNonAsync a >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)

9
Annex/AdjustedBranch.hs
View file

@ -209,7 +209,7 @@ enterAdjustedBranch adj = inRepo Git.Branch.current >>= \case
let adjbranch = adjBranch $ originalToAdjusted origbranch adj let adjbranch = adjBranch $ originalToAdjusted origbranch adj
ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getRead Annex.force) <&&> pure (not (is_branchView origbranch))) ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getRead Annex.force) <&&> pure (not (is_branchView origbranch)))
( do ( do
mapM_ (warning . unwords) mapM_ (warning . UnquotedString . unwords)
[ [ "adjusted branch" [ [ "adjusted branch"
, Git.Ref.describe adjbranch , Git.Ref.describe adjbranch
, "already exists." , "already exists."
@ -343,7 +343,7 @@ adjustedBranchRefreshFull adj origbranch = do
restagePointerFiles =<< Annex.gitRepo restagePointerFiles =<< Annex.gitRepo
let adjbranch = originalToAdjusted origbranch adj let adjbranch = originalToAdjusted origbranch adj
unlessM (updateAdjustedBranch adj adjbranch origbranch) $ unlessM (updateAdjustedBranch adj adjbranch origbranch) $
warning $ unwords [ "Updating adjusted branch failed." ] warning "Updating adjusted branch failed."
adjustToCrippledFileSystem :: Annex () adjustToCrippledFileSystem :: Annex ()
adjustToCrippledFileSystem = do adjustToCrippledFileSystem = do
@ -497,7 +497,7 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
Just currcommit -> Just currcommit ->
newcommits >>= go origsha False >>= \case newcommits >>= go origsha False >>= \case
Left e -> do Left e -> do
warning e warning (UnquotedString e)
return (Nothing, return ()) return (Nothing, return ())
Right newparent -> return Right newparent -> return
( Just newparent ( Just newparent
@ -505,7 +505,8 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
) )
Nothing -> return (Nothing, return ()) Nothing -> return (Nothing, return ())
Nothing -> do Nothing -> do
warning $ "Cannot find basis ref " ++ fromRef basis ++ "; not propagating adjusted commits to original branch " ++ fromRef origbranch warning $ UnquotedString $
"Cannot find basis ref " ++ fromRef basis ++ "; not propagating adjusted commits to original branch " ++ fromRef origbranch
return (Nothing, return ()) return (Nothing, return ())
where where
(BasisBranch basis) = basisBranch adjbranch (BasisBranch basis) = basisBranch adjbranch

3
Annex/BloomFilter.hs
View file

@ -27,7 +27,8 @@ bloomBitsHashes = do
accuracy <- bloomAccuracy accuracy <- bloomAccuracy
case safeSuggestSizing capacity (1 / fromIntegral accuracy) of case safeSuggestSizing capacity (1 / fromIntegral accuracy) of
Left e -> do Left e -> do
warning $ "bloomfilter " ++ e ++ "; falling back to sane value" warning $ UnquotedString $
"bloomfilter " ++ e ++ "; falling back to sane value"
-- precaulculated value for 500000 (1/10000000) -- precaulculated value for 500000 (1/10000000)
return (16777216,23) return (16777216,23)
Right v -> return v Right v -> return v

1
Annex/Common.hs
View file

@ -10,6 +10,7 @@ import Annex as X (gitRepo, inRepo, fromRepo, calcRepo, calcRepo')
import Annex.Locations as X import Annex.Locations as X
import Annex.Debug as X (fastDebug, debug) import Annex.Debug as X (fastDebug, debug)
import Messages as X import Messages as X
import Git.Filename as X
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix.IO as X hiding (createPipe) import System.Posix.IO as X hiding (createPipe)
#endif #endif

8
Annex/Content.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Content ( module Annex.Content (
inAnnex, inAnnex,
@ -447,7 +448,7 @@ checkSecureHashes' :: Key -> Annex Bool
checkSecureHashes' key = checkSecureHashes key >>= \case checkSecureHashes' key = checkSecureHashes key >>= \case
Nothing -> return True Nothing -> return True
Just msg -> do Just msg -> do
warning $ msg ++ "to annex objects" warning $ UnquotedString $ msg ++ "to annex objects"
return False return False
data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
@ -760,9 +761,10 @@ downloadUrl listfailedurls k p iv urls file uo =
go [] [] = return False go [] [] = return False
go [] errs@((_, err):_) = do go [] errs@((_, err):_) = do
if listfailedurls if listfailedurls
then warning $ unlines $ flip map errs $ \(u, err') -> then warning $ UnquotedString $
unlines $ flip map errs $ \(u, err') ->
u ++ " " ++ err' u ++ " " ++ err'
else warning err else warning $ UnquotedString err
return False return False
{- Copies a key's content, when present, to a temp file. {- Copies a key's content, when present, to a temp file.

3
Annex/Content/LowLevel.hs
View file

@ -126,7 +126,8 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRea
let delta = need + reserve - have - alreadythere + inprogress let delta = need + reserve - have - alreadythere + inprogress
let ok = delta <= 0 let ok = delta <= 0
unless ok $ unless ok $
warning $ needMoreDiskSpace delta warning $ UnquotedString $
needMoreDiskSpace delta
return ok return ok
_ -> return True _ -> return True
) )

2
Annex/Difference.hs
View file

@ -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 Annex.Difference ( module Annex.Difference (
module Types.Difference, module Types.Difference,
setDifferences, setDifferences,

3
Annex/Export.hs
View file

@ -15,6 +15,7 @@ import Types
import Types.Key import Types.Key
import qualified Git import qualified Git
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Git.Filename
import Messages import Messages
import Data.Maybe import Data.Maybe
@ -63,7 +64,7 @@ warnExportImportConflict r = do
(False, True) -> ("imported from", "git-annex import") (False, True) -> ("imported from", "git-annex import")
(True, False) -> ("exported to", "git-annex export") (True, False) -> ("exported to", "git-annex export")
_ -> ("exported to and/or imported from", "git-annex export") _ -> ("exported to and/or imported from", "git-annex export")
toplevelWarning True $ unwords toplevelWarning True $ UnquotedString $ unwords
[ "Conflict detected. Different trees have been" [ "Conflict detected. Different trees have been"
, ops, Remote.name r ++ ". Use" , ops, Remote.name r ++ ". Use"
, resolvcmd , resolvcmd

5
Annex/Hook.hs
View file

@ -66,7 +66,8 @@ hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
hookWarning :: Git.Hook -> String -> Annex () hookWarning :: Git.Hook -> String -> Annex ()
hookWarning h msg = do hookWarning h msg = do
r <- gitRepo r <- gitRepo
warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg warning $ UnquotedString $
Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
{- Runs a hook. To avoid checking if the hook exists every time, {- Runs a hook. To avoid checking if the hook exists every time,
- the existing hooks are cached. -} - the existing hooks are cached. -}
@ -84,4 +85,4 @@ runAnnexHook hook = do
where where
run = unlessM (inRepo $ Git.runHook hook) $ do run = unlessM (inRepo $ Git.runHook hook) $ do
h <- fromRepo $ Git.hookFile hook h <- fromRepo $ Git.hookFile hook
warning $ h ++ " failed" warning $ UnquotedString $ h ++ " failed"

10
Annex/Import.hs
View file

@ -510,7 +510,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
showNote "old version" showNote "old version"
tryNonAsync (importordownload cidmap db i largematcher) >>= \case tryNonAsync (importordownload cidmap db i largematcher) >>= \case
Left e -> next $ do Left e -> next $ do
warning (show e) warning (UnquotedString (show e))
liftIO $ atomically $ liftIO $ atomically $
putTMVar job Nothing putTMVar job Nothing
return False return False
@ -535,7 +535,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
return $ Just (loc, Right k) return $ Just (loc, Right k)
Right Nothing -> return Nothing Right Nothing -> return Nothing
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return Nothing return Nothing
importordownload cidmap db (loc, (cid, sz)) largematcher= do importordownload cidmap db (loc, (cid, sz)) largematcher= do
@ -578,7 +578,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
Right (Just (k, True)) -> return $ Just (loc, Right k) Right (Just (k, True)) -> return $ Just (loc, Right k)
Right _ -> return Nothing Right _ -> return Nothing
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return Nothing return Nothing
where where
importer = do importer = do
@ -634,7 +634,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
tryNonAsync (downloader tmpfile) >>= \case tryNonAsync (downloader tmpfile) >>= \case
Right sha -> return $ Just (loc, Left sha) Right sha -> return $ Just (loc, Left sha)
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return Nothing return Nothing
where where
tmpkey = importKey cid sz tmpkey = importKey cid sz
@ -662,7 +662,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
Right (v, True) -> return $ Just (loc, v) Right (v, True) -> return $ Just (loc, v)
Right (_, False) -> return Nothing Right (_, False) -> return Nothing
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return Nothing return Nothing
let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote)
checkDiskSpaceToGet tmpkey Nothing $ checkDiskSpaceToGet tmpkey Nothing $

20
Annex/Ingest.hs
View file

@ -48,7 +48,6 @@ import Utility.CopyFile
import Utility.Touch import Utility.Touch
import Utility.Metered import Utility.Metered
import Git.FilePath import Git.FilePath
import Git.Filename
import Annex.InodeSentinal import Annex.InodeSentinal
import Annex.AdjustedBranch import Annex.AdjustedBranch
import Annex.FileMatcher import Annex.FileMatcher
@ -88,7 +87,7 @@ data LockDownConfig = LockDownConfig
-} -}
lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown) lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown)
lockDown cfg file = either lockDown cfg file = either
(\e -> warning (show e) >> return Nothing) (\e -> warning (UnquotedString (show e)) >> return Nothing)
(return . Just) (return . Just)
=<< lockDown' cfg file =<< lockDown' cfg file
@ -227,7 +226,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
return (Just k, mcache) return (Just k, mcache)
failure msg = do failure msg = do
warning $ fromRawFilePath (keyFilename source) ++ " " ++ msg warning $ QuotedPath (keyFilename source) <> " " <> UnquotedString msg
cleanCruft source cleanCruft source
return (Nothing, Nothing) return (Nothing, Nothing)
@ -299,7 +298,7 @@ restoreFile file key e = do
-- content in the annex, and make a copy back to the file. -- content in the annex, and make a copy back to the file.
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $ unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $
warning $ "Unable to restore content of " ++ fromRawFilePath file ++ "; it should be located in " ++ obj warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj)
thawContent file thawContent file
throwM e throwM e
@ -412,11 +411,10 @@ addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a
addingExistingLink f k a = do addingExistingLink f k a = do
unlessM (isKnownKey k <||> inAnnex k) $ do unlessM (isKnownKey k <||> inAnnex k) $ do
islink <- isJust <$> isAnnexLink f islink <- isJust <$> isAnnexLink f
warning $ unwords warning $
[ fromRawFilePath f QuotedPath f
, "is a git-annex" <> " is a git-annex "
, if islink then "symlink." else "pointer file." <> if islink then "symlink." else "pointer file."
, "Its content is not available in this repository." <> " Its content is not available in this repository."
, "(Maybe " ++ fromRawFilePath f ++ " was copied from another repository?)" <> " (Maybe " <> QuotedPath f <> " was copied from another repository?)"
]
a a

4
Annex/Init.hs
View file

@ -79,7 +79,7 @@ checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case
Just noannexmsg -> do Just noannexmsg -> do
warning "Initialization prevented by .noannex file (remove the file to override)" warning "Initialization prevented by .noannex file (remove the file to override)"
unless (null noannexmsg) $ unless (null noannexmsg) $
warning noannexmsg warning (UnquotedString noannexmsg)
giveup "Not initialized." giveup "Not initialized."
initializeAllowed :: Annex Bool initializeAllowed :: Annex Bool
@ -272,7 +272,7 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
(Just (freezeContent' UnShared)) (Just (freezeContent' UnShared))
(Just (thawContent' UnShared)) (Just (thawContent' UnShared))
=<< hasFreezeHook =<< hasFreezeHook
mapM_ warning warnings mapM_ (warning . UnquotedString) warnings
return r return r
probeCrippledFileSystem' probeCrippledFileSystem'

21
Annex/Link.hs
View file

@ -186,7 +186,7 @@ newtype Restage = Restage Bool
restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()
restagePointerFile (Restage False) f orig = do restagePointerFile (Restage False) f orig = do
flip writeRestageLog orig =<< inRepo (toTopFilePath f) flip writeRestageLog orig =<< inRepo (toTopFilePath f)
toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f toplevelWarning True $ unableToRestage $ Just f
restagePointerFile (Restage True) f orig = do restagePointerFile (Restage True) f orig = do
flip writeRestageLog orig =<< inRepo (toTopFilePath f) flip writeRestageLog orig =<< inRepo (toTopFilePath f)
-- Avoid refreshing the index if run by the -- Avoid refreshing the index if run by the
@ -319,16 +319,15 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do
ck = ConfigKey "filter.annex.process" ck = ConfigKey "filter.annex.process"
ckd = ConfigKey "filter.annex.process-temp-disabled" ckd = ConfigKey "filter.annex.process-temp-disabled"
unableToRestage :: Maybe FilePath -> String unableToRestage :: Maybe RawFilePath -> StringContainingQuotedPath
unableToRestage mf = unwords unableToRestage mf =
[ "git status will show " ++ fromMaybe "some files" mf "git status will show " <> maybe "some files" QuotedPath mf
, "to be modified, since content availability has changed" <> " to be modified, since content availability has changed"
, "and git-annex was unable to update the index." <> " and git-annex was unable to update the index."
, "This is only a cosmetic problem affecting git status; git add," <> " This is only a cosmetic problem affecting git status; git add,"
, "git commit, etc won't be affected." <> " git commit, etc won't be affected."
, "To fix the git status display, you can run:" <> " To fix the git status display, you can run:"
, "git-annex restage" <> " git-annex restage"
]
{- Parses a symlink target or a pointer file to a Key. {- Parses a symlink target or a pointer file to a Key.
- -

3
Annex/LockPool/PosixOrPid.hs
View file

@ -32,6 +32,7 @@ import Utility.LockPool.STM (LockFile, LockMode(..))
import Utility.LockFile.LockStatus import Utility.LockFile.LockStatus
import Config (pidLockFile) import Config (pidLockFile)
import Messages (warning) import Messages (warning)
import Git.Filename
import System.Posix import System.Posix
@ -74,7 +75,7 @@ pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile
go (Just pidlock) = do go (Just pidlock) = do
timeout <- annexPidLockTimeout <$> Annex.getGitConfig timeout <- annexPidLockTimeout <$> Annex.getGitConfig
liftIO $ dummyPosixLock m f liftIO $ dummyPosixLock m f
Pid.waitLock f lockmode timeout pidlock warning Pid.waitLock f lockmode timeout pidlock (warning . UnquotedString)
tryPidLock :: Maybe FileMode -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle) tryPidLock :: Maybe FileMode -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)
tryPidLock m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile tryPidLock m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile

2
Annex/MetaData.hs
View file

@ -56,7 +56,7 @@ genMetaData key file mmtime = do
dateMetaData (posixSecondsToUTCTime mtime) old dateMetaData (posixSecondsToUTCTime mtime) old
Nothing -> noop Nothing -> noop
where where
warncopied = warning $ warncopied = warning $ UnquotedString $
"Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++ "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++
"If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file
-- If the only fields copied were date metadata, and they'll -- If the only fields copied were date metadata, and they'll

2
Annex/SpecialRemote.hs
View file

@ -99,7 +99,7 @@ autoEnable = do
showSideAction $ "Auto enabling special remote " ++ name showSideAction $ "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 (show e) Left e -> warning (UnquotedString (show e))
Right (_c, _u) -> Right (_c, _u) ->
when (cu /= u) $ when (cu /= u) $
setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu) setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)

4
Annex/Ssh.hs
View file

@ -120,8 +120,8 @@ sshCachingInfo (host, port) = go =<< sshCacheDir'
warnnocaching whynocaching = warnnocaching whynocaching =
whenM (annexAdviceNoSshCaching <$> Annex.getGitConfig) $ do whenM (annexAdviceNoSshCaching <$> Annex.getGitConfig) $ do
warning nocachingwarning warning $ UnquotedString nocachingwarning
warning whynocaching warning $ UnquotedString whynocaching
nocachingwarning = unwords nocachingwarning = unwords
[ "You have enabled concurrency, but git-annex is not able" [ "You have enabled concurrency, but git-annex is not able"

6
Annex/Transfer.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE CPP, BangPatterns #-} {-# LANGUAGE CPP, BangPatterns, OverloadedStrings #-}
module Annex.Transfer ( module Annex.Transfer (
module X, module X,
@ -200,7 +200,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
| observeBool v -> return v | observeBool v -> return v
| otherwise -> checkretry | otherwise -> checkretry
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
checkretry checkretry
where where
checkretry = do checkretry = do
@ -289,7 +289,7 @@ preCheckSecureHashes k meventualbackend a = case meventualbackend of
) )
) )
blocked variety = do blocked variety = do
warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" warning $ UnquotedString $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"
return observeFailure return observeFailure
type NumRetries = Integer type NumRetries = Integer

8
Annex/Url.hs
View file

@ -6,6 +6,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Url ( module Annex.Url (
withUrlOptions, withUrlOptions,
withUrlOptionsPromptingCreds, withUrlOptionsPromptingCreds,
@ -166,13 +168,13 @@ checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool
checkBoth url expected_size uo = checkBoth url expected_size uo =
liftIO (U.checkBoth url expected_size uo) >>= \case liftIO (U.checkBoth url expected_size uo) >>= \case
Right r -> return r Right r -> return r
Left err -> warning err >> return False Left err -> warning (UnquotedString err) >> return False
download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool
download meterupdate iv url file uo = download meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo) >>= \case liftIO (U.download meterupdate iv url file uo) >>= \case
Right () -> return True Right () -> return True
Left err -> warning err >> return False Left err -> warning (UnquotedString err) >> return False
download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ())
download' meterupdate iv url file uo = download' meterupdate iv url file uo =
@ -181,7 +183,7 @@ download' meterupdate iv url file uo =
exists :: U.URLString -> U.UrlOptions -> Annex Bool exists :: U.URLString -> U.UrlOptions -> Annex Bool
exists url uo = liftIO (U.exists url uo) >>= \case exists url uo = liftIO (U.exists url uo) >>= \case
Right b -> return b Right b -> return b
Left err -> warning err >> return False Left err -> warning (UnquotedString err) >> return False
getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo) getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo)
getUrlInfo url uo = liftIO (U.getUrlInfo url uo) getUrlInfo url uo = liftIO (U.getUrlInfo url uo)

3
Annex/Verify.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Verify ( module Annex.Verify (
shouldVerify, shouldVerify,
@ -152,7 +153,7 @@ verifyKeySize k f = case fromKey keySize k of
Nothing -> return True Nothing -> return True
warnUnverifiableInsecure :: Key -> Annex () warnUnverifiableInsecure :: Key -> Annex ()
warnUnverifiableInsecure k = warning $ unwords warnUnverifiableInsecure k = warning $ UnquotedString $ unwords
[ "Getting " ++ kv ++ " keys with this remote is not secure;" [ "Getting " ++ kv ++ " keys with this remote is not secure;"
, "the content cannot be verified to be correct." , "the content cannot be verified to be correct."
, "(Use annex.security.allow-unverified-downloads to bypass" , "(Use annex.security.allow-unverified-downloads to bypass"

2
Annex/YoutubeDl.hs
View file

@ -148,7 +148,7 @@ youtubeDlTo key url dest p = do
return (Just True) return (Just True)
Right Nothing -> return (Just False) Right Nothing -> return (Just False)
Left msg -> do Left msg -> do
warning msg warning (UnquotedString msg)
return Nothing return Nothing
return (fromMaybe False res) return (fromMaybe False res)

6
Assistant/Threads/Committer.hs
View file

@ -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 Assistant.Threads.Committer where module Assistant.Threads.Committer where
@ -433,8 +433,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
canceladd (InProcessAddChange { lockedDown = ld }) = do canceladd (InProcessAddChange { lockedDown = ld }) = do
let ks = keySource ld let ks = keySource ld
warning $ fromRawFilePath (keyFilename ks) warning $ QuotedPath (keyFilename ks)
++ " still has writers, not adding" <> " still has writers, not adding"
-- remove the hard link -- remove the hard link
when (contentLocation ks /= keyFilename ks) $ when (contentLocation ks /= keyFilename ks) $
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks

2
Assistant/Threads/MountWatcher.hs
View file

@ -74,7 +74,7 @@ dbusThread urlrenderer = do
onerr :: E.SomeException -> Assistant () onerr :: E.SomeException -> Assistant ()
onerr e = do onerr e = do
liftAnnex $ liftAnnex $
warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" warning $ UnquotedString $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
pollingThread urlrenderer pollingThread urlrenderer
{- Examine the list of services connected to dbus, to see if there {- Examine the list of services connected to dbus, to see if there

2
Assistant/Threads/NetWatcher.hs
View file

@ -78,7 +78,7 @@ dbusThread = do
sendRemoteControl RESUME sendRemoteControl RESUME
onerr e _ = do onerr e _ = do
liftAnnex $ liftAnnex $
warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" warning $ UnquotedString $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"
{- Wait, in hope that dbus will come back -} {- Wait, in hope that dbus will come back -}
liftIO $ threadDelaySeconds (Seconds 60) liftIO $ threadDelaySeconds (Seconds 60)

4
Assistant/Threads/PairListener.hs
View file

@ -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 Assistant.Threads.PairListener where module Assistant.Threads.PairListener where
import Assistant.Common import Assistant.Common
@ -49,7 +51,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
debug ["ignoring message that looped back"] debug ["ignoring message that looped back"]
go reqs cache sock go reqs cache sock
(_, _, False, _) -> do (_, _, False, _) -> do
liftAnnex $ warning $ liftAnnex $ warning $ UnquotedString $
"illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")" "illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")"
go reqs cache sock go reqs cache sock
-- PairReq starts a pairing process, so a -- PairReq starts a pairing process, so a

4
Assistant/Threads/SanityChecker.hs
View file

@ -127,7 +127,7 @@ sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ foreve
return r return r
showerr e = do showerr e = do
liftAnnex $ warning $ show e liftAnnex $ warning $ UnquotedString $ show e
return False return False
{- Only run one check per day, from the time of the last check. -} {- Only run one check per day, from the time of the last check. -}
@ -198,7 +198,7 @@ dailyCheck urlrenderer = do
toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime)
slop = fromIntegral tenMinutes slop = fromIntegral tenMinutes
insanity msg = do insanity msg = do
liftAnnex $ warning msg liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ sanityCheckFixAlert msg void $ addAlert $ sanityCheckFixAlert msg
addsymlink file s = do addsymlink file s = do
Watcher.runHandler Watcher.onAddSymlink file s Watcher.runHandler Watcher.onAddSymlink file s

4
Assistant/Threads/Watcher.hs
View file

@ -184,7 +184,7 @@ runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus r <- tryIO <~> handler (normalize file) filestatus
case r of case r of
Left e -> liftAnnex $ warning $ show e Left e -> liftAnnex $ warning $ UnquotedString $ show e
Right Nothing -> noop Right Nothing -> noop
Right (Just change) -> recordChange change Right (Just change) -> recordChange change
where where
@ -371,6 +371,6 @@ onDelDir dir _ = do
{- Called when there's an error with inotify or kqueue. -} {- Called when there's an error with inotify or kqueue. -}
onErr :: Handler onErr :: Handler
onErr msg _ = do onErr msg _ = do
liftAnnex $ warning msg liftAnnex $ warning (UnquotedString msg)
void $ addAlert $ warningAlert "watcher" msg void $ addAlert $ warningAlert "watcher" msg
noChange noChange

5
Backend.hs
View file

@ -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 Backend ( module Backend (
builtinList, builtinList,
defaultBackend, defaultBackend,
@ -66,7 +68,8 @@ getBackend :: FilePath -> Key -> Annex (Maybe Backend)
getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
Just backend -> return $ Just backend Just backend -> return $ Just backend
Nothing -> do Nothing -> do
warning $ "skipping " ++ file ++ " (" ++ unknownBackendVarietyMessage (fromKey keyVariety k) ++ ")" warning $ "skipping " <> QuotedPath (toRawFilePath file) <> " (" <>
UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")"
return Nothing return Nothing
unknownBackendVarietyMessage :: KeyVariety -> String unknownBackendVarietyMessage :: KeyVariety -> String

5
Backend/External.hs
View file

@ -139,7 +139,8 @@ handleRequest st req whenunavail responsehandler =
loop loop
where where
handleExceptionalMessage _ (ERROR err) = do handleExceptionalMessage _ (ERROR err) = do
warning ("external special remote error: " ++ err) warning $ UnquotedString $
"external special remote error: " ++ err
whenunavail whenunavail
handleExceptionalMessage loop (DEBUG msg) = do handleExceptionalMessage loop (DEBUG msg) = do
fastDebug "Backend.External" msg fastDebug "Backend.External" msg
@ -237,7 +238,7 @@ newExternalState ebname hasext pid = do
where where
basecmd = externalBackendProgram ebname basecmd = externalBackendProgram ebname
warnonce msg = when (pid == 1) $ warnonce msg = when (pid == 1) $
warning msg warning (UnquotedString msg)
externalBackendProgram :: ExternalBackendName -> String externalBackendProgram :: ExternalBackendName -> String
externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname

2
Backend/Hash.hs
View file

@ -130,7 +130,7 @@ checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do
_ -> return True _ -> return True
where where
hwfault e = do hwfault e = do
warning $ "hardware fault: " ++ show e warning $ UnquotedString $ "hardware fault: " ++ show e
return False return False
sameCheckSum :: Key -> String -> Bool sameCheckSum :: Key -> String -> Bool

2
CmdLine/Action.hs
View file

@ -192,7 +192,7 @@ accountCommandAction startmsg cleanup = tryNonAsync cleanup >>= \case
Left err -> case fromException err of Left err -> case fromException err of
Just exitcode -> liftIO $ exitWith exitcode Just exitcode -> liftIO $ exitWith exitcode
Nothing -> do Nothing -> do
toplevelWarning True (show err) toplevelWarning True (UnquotedString (show err))
showEndMessage startmsg False showEndMessage startmsg False
incerr incerr
where where

2
CmdLine/GitAnnex/Options.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
module CmdLine.GitAnnex.Options where module CmdLine.GitAnnex.Options where

8
CmdLine/Seek.hs
View file

@ -9,6 +9,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module CmdLine.Seek where module CmdLine.Seek where
import Annex.Common import Annex.Common
@ -566,9 +568,9 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
let p' = toRawFilePath p let p' = toRawFilePath p
relf <- liftIO $ relPathCwdToFile p' relf <- liftIO $ relPathCwdToFile p'
ifM (not <$> (exists p' <||> hidden currbranch relf)) ifM (not <$> (exists p' <||> hidden currbranch relf))
( prob (p ++ " not found") ( prob (QuotedPath (toRawFilePath p) <> " not found")
, ifM (viasymlink stopattop (upFrom relf)) , ifM (viasymlink stopattop (upFrom relf))
( prob (p ++ " is beyond a symbolic link") ( prob (QuotedPath (toRawFilePath p) <> " is beyond a symbolic link")
, return True , return True
) )
) )
@ -628,7 +630,7 @@ mkCheckTimeLimit = Annex.getState Annex.timelimit >>= \case
swapTVar warningshownv True swapTVar warningshownv True
unless warningshown $ do unless warningshown $ do
Annex.changeState $ \s -> s { Annex.reachedlimit = True } Annex.changeState $ \s -> s { Annex.reachedlimit = True }
warning $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..." warning $ UnquotedString $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..."
cleanup cleanup
else a else a

3
Command/Add.hs
View file

@ -25,7 +25,6 @@ import Messages.Progress
import Git.FilePath import Git.FilePath
import Git.Types import Git.Types
import Git.UpdateIndex import Git.UpdateIndex
import Git.Filename
import Config.GitConfig import Config.GitConfig
import Utility.OptParse import Utility.OptParse
import Utility.InodeCache import Utility.InodeCache
@ -175,7 +174,7 @@ addFile smallorlarge file s = do
s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
if maybe True (changed s) s' if maybe True (changed s) s'
then do then do
warning $ fromRawFilePath file ++ " changed while it was being added" warning $ QuotedPath file <> " changed while it was being added"
return False return False
else do else do
case smallorlarge of case smallorlarge of

21
Command/AddUrl.hs
View file

@ -34,7 +34,6 @@ import Utility.Metered
import Utility.HtmlDetect import Utility.HtmlDetect
import Utility.Path.Max import Utility.Path.Max
import Utility.Url (parseURIPortable) import Utility.Url (parseURIPortable)
import Git.Filename
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Annex.Transfer as Transfer import qualified Annex.Transfer as Transfer
@ -154,7 +153,7 @@ checkUrl addunlockedmatcher r o si u = do
where where
go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do
warning (show e) warning (UnquotedString (show e))
next $ return False next $ return False
go deffile (Right (UrlContents sz mf)) = do go deffile (Right (UrlContents sz mf)) = do
f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf
@ -234,7 +233,7 @@ startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURIPortab
else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case
Right urlinfo -> go' url urlinfo Right urlinfo -> go' url urlinfo
Left err -> do Left err -> do
warning err warning (UnquotedString err)
next $ return False next $ return False
go' url urlinfo = do go' url urlinfo = do
pathmax <- liftIO $ fileNameLengthLimit "." pathmax <- liftIO $ fileNameLengthLimit "."
@ -306,7 +305,7 @@ addUrlChecked o url file u checkexistssize key =
logChange key u InfoPresent logChange key u InfoPresent
next $ return True next $ return True
| otherwise -> do | otherwise -> do
warning $ "while adding a new url to an already annexed file, " ++ if exists warning $ UnquotedString $ "while adding a new url to an already annexed file, " ++ if exists
then "url does not have expected file size (use --relaxed to bypass this check) " ++ url then "url does not have expected file size (use --relaxed to bypass this check) " ++ url
else "failed to verify url exists: " ++ url else "failed to verify url exists: " ++ url
stop stop
@ -347,7 +346,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
Right mediafile -> Right mediafile ->
let f = youtubeDlDestFile o file (toRawFilePath mediafile) let f = youtubeDlDestFile o file (toRawFilePath mediafile)
in lookupKey f >>= \case in lookupKey f >>= \case
Just k -> alreadyannexed (fromRawFilePath f) k Just k -> alreadyannexed f k
Nothing -> dl f Nothing -> dl f
Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend) Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend)
where where
@ -366,7 +365,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend) Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
Left msg -> do Left msg -> do
cleanuptmp cleanuptmp
warning msg warning (UnquotedString msg)
return Nothing return Nothing
mediaurl = setDownloader url YoutubeDownloader mediaurl = setDownloader url YoutubeDownloader
mediakey = Backend.URL.fromUrl mediaurl Nothing mediakey = Backend.URL.fromUrl mediaurl Nothing
@ -377,13 +376,13 @@ downloadWeb addunlockedmatcher o url urlinfo file =
if mediaurl `elem` us if mediaurl `elem` us
then return (Just k) then return (Just k)
else do else do
warning $ dest ++ " already exists; not overwriting" warning $ QuotedPath dest <> " already exists; not overwriting"
return Nothing return Nothing
checkRaw :: (Maybe String) -> DownloadOptions -> a -> Annex a -> Annex a checkRaw :: (Maybe String) -> DownloadOptions -> a -> Annex a -> Annex a
checkRaw failreason o f a checkRaw failreason o f a
| noRawOption o = do | noRawOption o = do
warning $ "Unable to use youtube-dl or a special remote and --no-raw was specified" ++ warning $ UnquotedString $ "Unable to use youtube-dl or a special remote and --no-raw was specified" ++
case failreason of case failreason of
Just msg -> ": " ++ msg Just msg -> ": " ++ msg
Nothing -> "" Nothing -> ""
@ -507,7 +506,7 @@ nodownloadWeb addunlockedmatcher o url urlinfo file
Right mediafile -> usemedia (toRawFilePath mediafile) Right mediafile -> usemedia (toRawFilePath mediafile)
Left err -> checkRaw (Just err) o Nothing nomedia Left err -> checkRaw (Just err) o Nothing nomedia
| otherwise = do | otherwise = do
warning $ "unable to access url: " ++ url warning $ UnquotedString $ "unable to access url: " ++ url
return Nothing return Nothing
where where
nomedia = do nomedia = do
@ -565,11 +564,11 @@ data CanAddFile = CanAddFile
checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file)) checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file))
( do ( do
warning $ fromRawFilePath file ++ " already exists; not overwriting" warning $ QuotedPath file <> " already exists; not overwriting"
return Nothing return Nothing
, ifM (checkIgnored (checkGitIgnoreOption o) file) , ifM (checkIgnored (checkGitIgnoreOption o) file)
( do ( do
warning $ "not adding " ++ fromRawFilePath file ++ " which is .gitignored (use --no-check-gitignore to override)" warning $ "not adding " <> QuotedPath file <> " which is .gitignored (use --no-check-gitignore to override)"
return Nothing return Nothing
, a CanAddFile , a CanAddFile
) )

2
Command/DropUnused.hs
View file

@ -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.DropUnused where module Command.DropUnused where
import Command import Command

2
Command/EnableTor.hs
View file

@ -111,7 +111,7 @@ checkHiddenService = bracket setup cleanup go
-- we just want to know if the tor circuit works. -- we just want to know if the tor circuit works.
liftIO (tryNonAsync $ connectPeer g addr) >>= \case liftIO (tryNonAsync $ connectPeer g addr) >>= \case
Left e -> do Left e -> do
warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.." warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."
liftIO $ threadDelaySeconds (Seconds 2) liftIO $ threadDelaySeconds (Seconds 2)
check (n-1) addrs check (n-1) addrs
Right conn -> do Right conn -> do

2
Command/Export.hs
View file

@ -435,7 +435,7 @@ performRename r db ek src dest =
tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case
Right (Just ()) -> next $ cleanupRename r db ek src dest Right (Just ()) -> next $ cleanupRename r db ek src dest
Left err -> do Left err -> do
warning $ "rename failed (" ++ show err ++ "); deleting instead" warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead"
fallbackdelete fallbackdelete
-- remote does not support renaming -- remote does not support renaming
Right Nothing -> fallbackdelete Right Nothing -> fallbackdelete

4
Command/FromKey.hs
View file

@ -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.FromKey where module Command.FromKey where
import Command import Command
@ -130,7 +132,7 @@ perform matcher key file = lookupKeyNotHidden file >>= \case
| otherwise -> hasothercontent | otherwise -> hasothercontent
where where
hasothercontent = do hasothercontent = do
warning $ fromRawFilePath file ++ " already exists with different content" warning $ QuotedPath file <> " already exists with different content"
next $ return False next $ return False
linkunlocked = linkFromAnnex key file Nothing >>= \case linkunlocked = linkFromAnnex key file Nothing >>= \case

87
Command/Fsck.hs
View file

@ -167,7 +167,7 @@ performRemote key afile backend numcopies remote =
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 qp <- coreQuotePath <$> Annex.getGitConfig
warning (decodeBS (actionItemDesc qp ai) ++ ": failed to download file from remote") warning $ UnquotedString (decodeBS (actionItemDesc qp ai)) <> ": 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
@ -320,7 +320,7 @@ verifyLocationLog key keystatus ai = do
KeyLockedThin -> thawContent obj KeyLockedThin -> thawContent obj
_ -> freezeContent obj _ -> freezeContent obj
checkContentWritePerm obj >>= \case checkContentWritePerm obj >>= \case
Nothing -> warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set" Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set"
_ -> return () _ -> return ()
whenM (liftIO $ R.doesPathExist $ parentDir obj) $ whenM (liftIO $ R.doesPathExist $ parentDir obj) $
freezeContentDir obj freezeContentDir obj
@ -331,7 +331,7 @@ verifyLocationLog key keystatus ai = do
- config was set. -} - config was set. -}
whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $ whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
warning $ "** Despite annex.securehashesonly being set, " ++ fromRawFilePath obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key"
verifyLocationLog' key ai present u (logChange key u) verifyLocationLog' key ai present u (logChange key u)
@ -352,9 +352,9 @@ verifyLocationLog' key ai present u updatestatus = do
fix InfoMissing fix InfoMissing
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
warning $ warning $
"** Based on the location log, " ++ "** Based on the location log, " <>
decodeBS (actionItemDesc qp ai) ++ QuotedPath (actionItemDesc qp 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
(False, False) -> do (False, False) -> do
@ -393,10 +393,10 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
warning $ warning $
"** Required content " ++ "** Required content " <>
decodeBS (actionItemDesc qp ai) ++ QuotedPath (actionItemDesc qp ai) <>
" is missing from these repositories:\n" ++ " is missing from these repositories:\n" <>
missingrequired UnquotedString missingrequired
return False return False
verifyRequiredContent _ _ = return True verifyRequiredContent _ _ = return True
@ -468,13 +468,12 @@ checkKeySizeOr bad key file ai = case fromKey keySize key of
badsize a b = do badsize a b = do
msg <- bad key msg <- bad key
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
warning $ concat warning $
[ decodeBS (actionItemDesc qp ai) QuotedPath (actionItemDesc qp ai)
, ": Bad file size (" <> ": Bad file size ("
, compareSizes storageUnits True a b <> UnquotedString (compareSizes storageUnits True a b)
, "); " <> "); "
, msg <> UnquotedString msg
]
{- Check for keys that are upgradable. {- Check for keys that are upgradable.
- -
@ -487,13 +486,13 @@ 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 qp <- coreQuotePath <$> Annex.getGitConfig
warning $ concat warning $
[ decodeBS (actionItemDesc qp ai) 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="
, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key)))
, decodeBS file <> " "
] <> QuotedPath file
return True return True
_ -> return True _ -> return True
checkKeyUpgrade _ _ _ (AssociatedFile Nothing) = checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
@ -539,11 +538,10 @@ checkBackendOr bad backend key file ai =
unless ok $ do unless ok $ do
msg <- bad key msg <- bad key
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
warning $ concat warning $
[ decodeBS (actionItemDesc qp ai) QuotedPath (actionItemDesc qp ai)
, ": Bad file content; " <> ": Bad file content; "
, msg <> UnquotedString msg
]
return ok return ok
Nothing -> return True Nothing -> return True
@ -568,17 +566,16 @@ checkInodeCache key content mic ai = case mic of
Nothing -> noop Nothing -> noop
Just ic' -> whenM (compareInodeCaches ic ic') $ do Just ic' -> whenM (compareInodeCaches ic ic') $ do
qp <- coreQuotePath <$> Annex.getGitConfig qp <- coreQuotePath <$> Annex.getGitConfig
warning $ concat warning $
[ decodeBS (actionItemDesc qp ai) 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]
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do checkKeyNumCopies key afile numcopies = do
let (desc, hasafile) = case afile of let (desc, hasafile) = case afile of
AssociatedFile Nothing -> (serializeKey key, False) AssociatedFile Nothing -> (serializeKey' key, False)
AssociatedFile (Just af) -> (fromRawFilePath af, True) AssociatedFile (Just af) -> (af, True)
locs <- loggedLocations key locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs (untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations (deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations
@ -598,21 +595,21 @@ checkKeyNumCopies key afile numcopies = do
) )
else return True else return True
missingNote :: String -> Int -> NumCopies -> String -> String -> String missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
missingNote file 0 _ [] dead = missingNote file 0 _ [] dead =
"** No known copies exist of " ++ file ++ honorDead dead "** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead)
missingNote file 0 _ untrusted dead = missingNote file 0 _ untrusted dead =
"Only these untrusted locations may have copies of " ++ file ++ "Only these untrusted locations may have copies of " <> QuotedPath file <>
"\n" ++ untrusted ++ "\n" <> UnquotedString untrusted <>
"Back it up to trusted locations with git-annex copy." ++ honorDead dead "Back it up to trusted locations with git-annex copy." <> UnquotedString (honorDead dead)
missingNote file present needed [] _ = missingNote file present needed [] _ =
"Only " ++ show present ++ " of " ++ show (fromNumCopies needed) ++ "Only " <> UnquotedString (show present) <> " of " <> UnquotedString (show (fromNumCopies needed)) <>
" trustworthy copies exist of " ++ file ++ " trustworthy copies exist of " <> QuotedPath file <>
"\nBack it up with git-annex copy." "\nBack it up with git-annex copy."
missingNote file present needed untrusted dead = missingNote file present needed untrusted dead =
missingNote file present needed [] dead ++ missingNote file present needed [] dead <>
"\nThe following untrusted locations may also have copies: " ++ "\nThe following untrusted locations may also have copies: " <>
"\n" ++ untrusted "\n" <> UnquotedString untrusted
honorDead :: String -> String honorDead :: String -> String
honorDead dead honorDead dead

11
Command/Import.hs
View file

@ -31,7 +31,6 @@ import Annex.RemoteTrackingBranch
import Utility.InodeCache import Utility.InodeCache
import Logs.Location import Logs.Location
import Git.FilePath import Git.FilePath
import Git.Filename
import Git.Types import Git.Types
import Types.Import import Types.Import
import Utility.Metered import Utility.Metered
@ -171,7 +170,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
ignored <- checkIgnored (checkGitIgnoreOption o) destfile ignored <- checkIgnored (checkGitIgnoreOption o) destfile
if ignored if ignored
then do then do
warning $ "not importing " ++ fromRawFilePath destfile ++ " which is .gitignored (use --no-check-gitignore to override)" warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)"
stop stop
else do else do
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile) existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
@ -199,7 +198,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
Just s Just s
| isDirectory s -> cont | isDirectory s -> cont
| otherwise -> do | otherwise -> do
warning $ "not importing " ++ fromRawFilePath destfile ++ " because " ++ fromRawFilePath destdir ++ " is not a directory" warning $ "not importing " <> QuotedPath destfile <> " because " <> QuotedPath destdir <> " is not a directory"
stop stop
importfilechecked ld k = do importfilechecked ld k = do
@ -257,7 +256,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
, Command.Add.addSmall (DryRun False) destfile s , Command.Add.addSmall (DryRun False) destfile s
) )
notoverwriting why = do notoverwriting why = do
warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why warning $ "not overwriting existing " <> QuotedPath destfile <> " " <> UnquotedString why
stop stop
lockdown a = do lockdown a = do
let mi = MatchingFile $ FileInfo let mi = MatchingFile $ FileInfo
@ -335,7 +334,7 @@ seekRemote remote branch msubdir importcontent ci = do
liftIO (atomically (readTVar importabletvar)) >>= \case liftIO (atomically (readTVar importabletvar)) >>= \case
Nothing -> return () Nothing -> return ()
Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case
Nothing -> warning $ concat Nothing -> warning $ UnquotedString $ concat
[ "Failed to import some files from " [ "Failed to import some files from "
, Remote.name remote , Remote.name remote
, ". Re-run command to resume import." , ". Re-run command to resume import."
@ -388,5 +387,5 @@ commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig
setRemoteTrackingBranch tb c setRemoteTrackingBranch tb c
return True return True
Nothing -> do Nothing -> do
warning $ "Nothing to import and " ++ fromRef branch ++ " does not exist." warning $ UnquotedString $ "Nothing to import and " ++ fromRef branch ++ " does not exist."
return False return False

8
Command/ImportFeed.hs
View file

@ -228,7 +228,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio
else Url.withUrlOptions (Url.getUrlInfo url) >>= \case else Url.withUrlOptions (Url.getUrlInfo url) >>= \case
Right urlinfo -> go urlinfo Right urlinfo -> go urlinfo
Left err -> do Left err -> do
warning err warning (UnquotedString err)
return (Just []) return (Just [])
else do else do
res <- tryNonAsync $ maybe res <- tryNonAsync $ maybe
@ -349,7 +349,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio
-- an enclosure. -- an enclosure.
Right Nothing -> Just <$> downloadlink True Right Nothing -> Just <$> downloadlink True
Left msg -> do Left msg -> do
warning $ linkurl ++ ": " ++ msg warning $ UnquotedString $ linkurl ++ ": " ++ msg
return Nothing return Nothing
return (fromMaybe False r) return (fromMaybe False r)
, downloadlink False , downloadlink False
@ -477,10 +477,10 @@ noneValue = "none"
feedProblem :: URLString -> String -> Annex Bool feedProblem :: URLString -> String -> Annex Bool
feedProblem url message = ifM (checkFeedBroken url) feedProblem url message = ifM (checkFeedBroken url)
( do ( do
warning $ message ++ " (having repeated problems with feed: " ++ url ++ ")" warning $ UnquotedString $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
return False return False
, do , do
warning $ "warning: " ++ message warning $ UnquotedString $ "warning: " ++ message
return True return True
) )

4
Command/Multicast.hs
View file

@ -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 Command.Multicast where module Command.Multicast where
@ -211,7 +211,7 @@ storeReceived :: FilePath -> Annex ()
storeReceived f = do storeReceived f = do
case deserializeKey (takeFileName f) of case deserializeKey (takeFileName f) of
Nothing -> do Nothing -> do
warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file."
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
Just k -> void $ logStatusAfter k $ Just k -> void $ logStatusAfter k $
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $

2
Command/P2P.hs
View file

@ -152,7 +152,7 @@ performPairing remotename addrs = do
warning "Failed receiving data from pair." warning "Failed receiving data from pair."
return False return False
LinkFailed e -> do LinkFailed e -> do
warning $ "Failed linking to pair: " ++ e warning $ UnquotedString $ "Failed linking to pair: " ++ e
return False return False
where where
ui observer producer = do ui observer producer = do

3
Command/ReKey.hs
View file

@ -19,7 +19,6 @@ import Annex.ReplaceFile
import Logs.Location import Logs.Location
import Annex.InodeSentinal import Annex.InodeSentinal
import Annex.WorkTree import Annex.WorkTree
import Git.Filename
import Utility.InodeCache import Utility.InodeCache
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
@ -118,7 +117,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
ic <- withTSDelta (liftIO . genInodeCache file) ic <- withTSDelta (liftIO . genInodeCache file)
case v of case v of
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return False return False
Right () -> do Right () -> do
r <- linkToAnnex newkey file ic r <- linkToAnnex newkey file ic

1
Command/Reinject.hs
View file

@ -18,7 +18,6 @@ import Utility.Metered
import Annex.WorkTree import Annex.WorkTree
import qualified Git import qualified Git
import qualified Annex import qualified Annex
import Git.Filename
cmd :: Command cmd :: Command
cmd = withAnnexOptions [backendOption] $ cmd = withAnnexOptions [backendOption] $

6
Command/Smudge.hs
View file

@ -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.Smudge where module Command.Smudge where
import Command import Command
@ -142,7 +144,7 @@ clean' file mk passthrough discardreststdin emitpointer =
Right Nothing -> notpointer Right Nothing -> notpointer
Left InvalidAppendedPointerFile -> do Left InvalidAppendedPointerFile -> do
toplevelWarning False $ toplevelWarning False $
"The file \"" ++ fromRawFilePath file ++ "\" looks like git-annex pointer file that has had other content appended to it" "The file " <> QuotedPath file <> " looks like git-annex pointer file that has had other content appended to it"
notpointer notpointer
notpointer = inRepo (Git.Ref.fileRef file) >>= \case notpointer = inRepo (Git.Ref.fileRef file) >>= \case
@ -329,5 +331,5 @@ updateSmudged restage = streamSmudged $ \k topf -> do
else Database.Keys.addInodeCaches k [ic] else Database.Keys.addInodeCaches k [ic]
Nothing -> liftIO (isPointerFile f) >>= \case Nothing -> liftIO (isPointerFile f) >>= \case
Just k' | k' == k -> toplevelWarning False $ Just k' | k' == k -> toplevelWarning False $
"unable to populate worktree file " ++ fromRawFilePath f "unable to populate worktree file " <> QuotedPath f
_ -> noop _ -> noop

6
Command/Sync.hs
View file

@ -403,7 +403,7 @@ mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \c
let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch) let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch)
let si = SeekInput [] let si = SeekInput []
starting "merge" ai si $ do starting "merge" ai si $ do
warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it." warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it."
next $ return False next $ return False
Nothing -> stop Nothing -> stop
@ -533,7 +533,7 @@ importRemote importcontent o remote currbranch
-- mergeing it. -- mergeing it.
mc <- mergeConfig True mc <- mergeConfig True
void $ mergeRemote remote currbranch mc o void $ mergeRemote remote currbranch mc o
else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content." else warning $ UnquotedString $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content."
where where
wantpull = remoteAnnexPull (Remote.gitconfig remote) wantpull = remoteAnnexPull (Remote.gitconfig remote)
@ -604,7 +604,7 @@ pushRemote o remote (Just branch, _) = do
if ok if ok
then postpushupdate repo then postpushupdate repo
else do else do
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] warning $ UnquotedString $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
return ok return ok
where where
ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) ai = ActionItemOther (Just (UnquotedString (Remote.name remote)))

1
Command/TestRemote.hs
View file

@ -32,7 +32,6 @@ import Annex.SpecialRemote.Config (exportTreeField)
import Remote.Helper.Chunked import Remote.Helper.Chunked
import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Remote.Helper.Encryptable (encryptionField, highRandomQualityField)
import Git.Types import Git.Types
import Git.Filename
import Test.Tasty import Test.Tasty
import Test.Tasty.Runners import Test.Tasty.Runners

4
Command/TransferKey.hs
View file

@ -57,7 +57,7 @@ toPerform key file remote = go Upload file $
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
return True return True
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return False return False
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
@ -67,7 +67,7 @@ fromPerform key file remote = go Upload file $
tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)
where where
vc = RemoteVerify remote vc = RemoteVerify remote

4
Command/TransferKeys.hs
View file

@ -43,7 +43,7 @@ start = do
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return False return False
Right () -> do Right () -> do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
@ -53,7 +53,7 @@ start = do
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)
Right v -> return (True, v) Right v -> return (True, v)
-- Make sure we get the current -- Make sure we get the current

4
Command/Transferrer.hs
View file

@ -64,7 +64,7 @@ start = do
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key file p) >>= \case
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return False return False
Right () -> do Right () -> do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
@ -75,7 +75,7 @@ start = do
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
Left e -> do Left e -> do
warning (show e) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)
Right v -> return (True, v) Right v -> return (True, v)
-- Make sure we get the current -- Make sure we get the current

2
Command/Trust.hs
View file

@ -40,7 +40,7 @@ trustCommand c level ps = withStrings (commandAction . start) ps
groupSet uuid S.empty groupSet uuid S.empty
l <- lookupTrust uuid l <- lookupTrust uuid
when (l /= level) $ when (l /= level) $
warning $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "." warning $ UnquotedString $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "."
next $ return True next $ return True
trustedNeedsForce :: String -> String trustedNeedsForce :: String -> String

1
Command/Undo.hs
View file

@ -14,7 +14,6 @@ import Git.DiffTree
import Git.FilePath import Git.FilePath
import Git.UpdateIndex import Git.UpdateIndex
import Git.Sha import Git.Sha
import Git.Filename
import qualified Annex import qualified Annex
import qualified Git.LsFiles as LsFiles import qualified Git.LsFiles as LsFiles
import qualified Git.Command as Git import qualified Git.Command as Git

2
Command/View.hs
View file

@ -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.View where module Command.View where
import Command import Command

2
Command/Whereis.hs
View file

@ -142,7 +142,7 @@ getRemoteUrls key remote
Just w -> tryNonAsync (w key) >>= \case Just w -> tryNonAsync (w key) >>= \case
Right l -> pure l Right l -> pure l
Left e -> do Left e -> do
warning $ unwords warning $ UnquotedString $ unwords
[ "unable to query remote" [ "unable to query remote"
, name remote , name remote
, "for urls:" , "for urls:"

2
Creds.hs
View file

@ -156,7 +156,7 @@ getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredP
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
where where
go Nothing = do go Nothing = do
warning $ missingCredPairFor this storage warning $ UnquotedString $ missingCredPairFor this storage
return Nothing return Nothing
go (Just credpair) = return $ Just credpair go (Just credpair) = return $ Just credpair

31
Messages.hs
View file

@ -55,6 +55,7 @@ module Messages (
import Control.Concurrent import Control.Concurrent
import Control.Monad.IO.Class import Control.Monad.IO.Class
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Common import Common
import Types import Types
@ -183,16 +184,16 @@ showOutput = unlessM commandProgressDisabled $
outputMessage JSON.none "\n" outputMessage JSON.none "\n"
showLongNote :: String -> Annex () showLongNote :: String -> Annex ()
showLongNote s = outputMessage (JSON.note s) (encodeBS (formatLongNote s)) showLongNote s = outputMessage (JSON.note s) (formatLongNote (encodeBS s))
formatLongNote :: String -> String 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 :: String -> Annex ()
showInfo s = outputMessage' outputJSON (JSON.info s) $ showInfo s = outputMessage' outputJSON (JSON.info s) $
encodeBS (formatLongNote s) formatLongNote (encodeBS s)
showEndOk :: Annex () showEndOk :: Annex ()
showEndOk = showEndResult True showEndOk = showEndResult True
@ -207,20 +208,20 @@ endResult :: Bool -> S.ByteString
endResult True = "ok" endResult True = "ok"
endResult False = "failed" endResult False = "failed"
toplevelWarning :: Bool -> String -> Annex () toplevelWarning :: Bool -> StringContainingQuotedPath -> Annex ()
toplevelWarning makeway s = warning' makeway ("git-annex: " ++ s) toplevelWarning makeway s = warning' makeway id ("git-annex: " <> s)
warning :: String -> Annex () warning :: StringContainingQuotedPath -> Annex ()
warning = warning' True . indent warning = warning' True indent
earlyWarning :: String -> Annex () earlyWarning :: StringContainingQuotedPath -> Annex ()
earlyWarning = warning' False earlyWarning = warning' False id
warning' :: Bool -> String -> Annex () warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
warning' makeway w = do warning' makeway consolewhitespacef w = do
when makeway $ when makeway $
outputMessage JSON.none "\n" outputMessage JSON.none "\n"
outputError (w ++ "\n") outputError consolewhitespacef (w <> "\n")
{- Not concurrent output safe. -} {- Not concurrent output safe. -}
warningIO :: String -> IO () warningIO :: String -> IO ()
@ -229,8 +230,8 @@ warningIO w = do
hFlush stdout hFlush stdout
hPutStrLn stderr w hPutStrLn stderr w
indent :: String -> String indent :: S.ByteString -> S.ByteString
indent = intercalate "\n" . map (\l -> " " ++ l) . lines indent = S.intercalate "\n" . map (" " <>) . S8.lines
{- Shows a JSON chunk only when in json mode. -} {- Shows a JSON chunk only when in json mode. -}
maybeShowJSON :: JSON.JSONChunk v -> Annex () maybeShowJSON :: JSON.JSONChunk v -> Annex ()

29
Messages/Internal.hs
View file

@ -1,6 +1,6 @@
{- git-annex output messages, including concurrent output to display regions {- git-annex output messages, including concurrent output to display regions
- -
- Copyright 2010-2020 Joey Hess <id@joeyh.name> - Copyright 2010-2023 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -13,6 +13,8 @@ import Types.Messages
import Messages.Concurrent import Messages.Concurrent
import qualified Messages.JSON as JSON import qualified Messages.JSON as JSON
import Messages.JSON (JSONBuilder) import Messages.JSON (JSONBuilder)
import Git.Filename
import Types.GitConfig
import qualified Data.ByteString as S import qualified Data.ByteString as S
@ -75,22 +77,27 @@ outputJSON jsonbuilder s = case outputType s of
(fst <$> jsonbuilder Nothing) (fst <$> jsonbuilder Nothing)
return True return True
outputError :: String -> Annex () outputError :: (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of outputError consolewhitespacef msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
(JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions -> (JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->
let jb' = Just (JSON.addErrorMessage (lines msg) jb) let jb' = Just (JSON.addErrorMessage (lines (decodeBS (noquote msg))) jb)
in Annex.changeState $ \st -> in Annex.changeState $ \st ->
st { Annex.output = s { jsonBuffer = jb' } } st { Annex.output = s { jsonBuffer = jb' } }
(SerializedOutput h _, _) -> (SerializedOutput h _, _) -> do
liftIO $ outputSerialized h $ OutputError msg qp <- coreQuotePath <$> Annex.getGitConfig
liftIO $ outputSerialized h $ OutputError $ decodeBS $
consolewhitespacef $ quote qp msg
_ _
| concurrentOutputEnabled s -> concurrentMessage s True msg go | concurrentOutputEnabled s -> do
qp <- coreQuotePath <$> Annex.getGitConfig
concurrentMessage s True (decodeBS $ consolewhitespacef $ quote qp msg) go
| otherwise -> go | otherwise -> go
where where
go = liftIO $ do go = do
hFlush stdout qp <- coreQuotePath <$> Annex.getGitConfig
hPutStr stderr msg liftIO $ hFlush stdout
hFlush stderr liftIO $ S.hPutStr stderr (consolewhitespacef $ quote qp msg)
liftIO $ hFlush stderr
q :: Monad m => m () q :: Monad m => m ()
q = noop q = noop

3
Messages/Serialized.hs
View file

@ -21,6 +21,7 @@ import Messages.Internal
import Messages.Progress import Messages.Progress
import qualified Messages.JSON as JSON import qualified Messages.JSON as JSON
import Utility.Metered (BytesProcessed, setMeterTotalSize) import Utility.Metered (BytesProcessed, setMeterTotalSize)
import Git.Filename
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
@ -54,7 +55,7 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing
msg msg
loop st loop st
Left (OutputError msg) -> do Left (OutputError msg) -> do
runannex $ outputError msg runannex $ outputError id $ UnquotedString msg
loop st loop st
Left (JSONObject b) -> do Left (JSONObject b) -> do
runannex $ withMessageState $ \s -> case outputType s of runannex $ withMessageState $ \s -> case outputType s of

1
Remote/Adb.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Remote.Adb (remote) where module Remote.Adb (remote) where

4
Remote/External.hs
View file

@ -583,7 +583,7 @@ receiveMessage st external handleresponse handlerequest handleexceptional =
Just msg -> maybe (protocolError True s) id (handleexceptional msg) Just msg -> maybe (protocolError True s) id (handleexceptional msg)
Nothing -> protocolError False s Nothing -> protocolError False s
protocolError parsed s = do protocolError parsed s = do
warning $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ warning $ UnquotedString $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++
if parsed if parsed
then "(command not allowed at this time)" then "(command not allowed at this time)"
else "(unable to parse command)" else "(unable to parse command)"
@ -713,7 +713,7 @@ startExternal' external = do
] ++ exrest ] ++ exrest
unusable msg = do unusable msg = do
warning msg warning (UnquotedString msg)
giveup ("unable to use external special remote " ++ basecmd) giveup ("unable to use external special remote " ++ basecmd)
stopExternal :: External -> Annex () stopExternal :: External -> Annex ()

3
Remote/External/AsyncExtension.hs vendored
View file

@ -7,6 +7,7 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Remote.External.AsyncExtension (runRelayToExternalAsync) where module Remote.External.AsyncExtension (runRelayToExternalAsync) where
@ -86,7 +87,7 @@ receiveloop external st jidmap sendq sendthread annexrunner = externalReceive st
Nothing -> closeandshutdown Nothing -> closeandshutdown
where where
protoerr s = do protoerr s = do
annexrunner $ warning $ "async external special remote protocol error: " ++ s annexrunner $ warning $ "async external special remote protocol error: " <> s
closeandshutdown closeandshutdown
closeandshutdown = do closeandshutdown = do

2
Remote/GCrypt.hs
View file

@ -122,7 +122,7 @@ gen baser u rc gc rs = do
setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
gen' r u' pc gc rs gen' r u' pc gc rs
_ -> do _ -> do
warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r warning $ UnquotedString $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r
return Nothing return Nothing
gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)

20
Remote/Git.hs
View file

@ -275,12 +275,12 @@ tryGitConfigRead autoinit r hasuuid
case v of case v of
Right (r', val, _err) -> do Right (r', val, _err) -> do
unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do
warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
warning $ "Instead, got: " ++ show val warning $ UnquotedString $ "Instead, got: " ++ show val
warning $ "This is unexpected; please check the network transport!" warning "This is unexpected; please check the network transport!"
return $ Right r' return $ Right r'
Left l -> do Left l -> do
warning $ "Unable to parse git config from " ++ configloc warning $ UnquotedString $ "Unable to parse git config from " ++ configloc
return $ Left (show l) return $ Left (show l)
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
@ -306,7 +306,7 @@ tryGitConfigRead autoinit r hasuuid
return r' return r'
Left err -> do Left err -> do
set_ignore "not usable by git-annex" False set_ignore "not usable by git-annex" False
warning $ url ++ " " ++ err warning $ UnquotedString $ url ++ " " ++ err
return r return r
{- Is this remote just not available, or does {- Is this remote just not available, or does
@ -323,9 +323,9 @@ tryGitConfigRead autoinit r hasuuid
case Git.remoteName r of case Git.remoteName r of
Nothing -> noop Nothing -> noop
Just n -> do Just n -> do
warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore" warning $ UnquotedString $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"
when longmessage $ when longmessage $
warning $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n warning $ UnquotedString $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n
setremote setRemoteIgnore True setremote setRemoteIgnore True
setremote setter v = case Git.remoteName r of setremote setter v = case Git.remoteName r of
@ -348,7 +348,7 @@ tryGitConfigRead autoinit r hasuuid
let check = do let check = do
Annex.BranchState.disableUpdate Annex.BranchState.disableUpdate
catchNonAsync (autoInitialize (pure [])) $ \e -> catchNonAsync (autoInitialize (pure [])) $ \e ->
warning $ "Remote " ++ Git.repoDescribe r ++ warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++
": " ++ show e ": " ++ show e
Annex.getState Annex.repo Annex.getState Annex.repo
s <- newLocal r s <- newLocal r
@ -359,7 +359,7 @@ tryGitConfigRead autoinit r hasuuid
unless hasuuid $ case Git.remoteName r of unless hasuuid $ case Git.remoteName r of
Nothing -> noop Nothing -> noop
Just n -> do Just n -> do
warning $ "Remote " ++ n ++ " cannot currently be accessed." warning $ UnquotedString $ "Remote " ++ n ++ " cannot currently be accessed."
return r return r
configlistfields = if autoinit configlistfields = if autoinit
@ -770,7 +770,7 @@ mkState r u gc = do
let ok = u' == u let ok = u' == u
void $ liftIO $ tryPutMVar cv ok void $ liftIO $ tryPutMVar cv ok
unless ok $ unless ok $
warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now." warning $ UnquotedString $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."
return ok return ok
, liftIO $ readMVar cv , liftIO $ readMVar cv
) )

6
Remote/GitLFS.hs
View file

@ -253,7 +253,7 @@ discoverLFSEndpoint tro h
warning "Unable to parse ssh url for git-lfs remote." warning "Unable to parse ssh url for git-lfs remote."
return Nothing return Nothing
Just (Left err) -> do Just (Left err) -> do
warning err warning (UnquotedString err)
return Nothing return Nothing
Just (Right hostuser) -> do Just (Right hostuser) -> do
let port = Git.Url.port r let port = Git.Url.port r
@ -275,11 +275,11 @@ discoverLFSEndpoint tro h
(sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd (sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd
liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case
Left err -> do Left err -> do
warning $ "ssh connection to git-lfs remote failed: " ++ show err warning $ UnquotedString $ "ssh connection to git-lfs remote failed: " ++ show err
return Nothing return Nothing
Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of
Nothing -> do Nothing -> do
warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery" warning "unexpected response from git-lfs remote when doing ssh endpoint discovery"
return Nothing return Nothing
Just endpoint -> return (Just endpoint) Just endpoint -> return (Just endpoint)

2
Remote/Helper/Chunked/Legacy.hs
View file

@ -100,7 +100,7 @@ storeChunked annexrunner chunksize dests storer content =
| otherwise = storechunks sz [] dests content | otherwise = storechunks sz [] dests content
onerr e = do onerr e = do
annexrunner $ warning (show e) annexrunner $ warning (UnquotedString (show e))
return [] return []
storechunks _ _ [] _ = return [] -- ran out of dests storechunks _ _ [] _ = return [] -- ran out of dests

2
Remote/Helper/Ssh.hs
View file

@ -298,7 +298,7 @@ runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do
-- When runFullProto fails, the connection is no longer -- When runFullProto fails, the connection is no longer
-- usable, so close it. -- usable, so close it.
Left e -> do Left e -> do
warning $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")" warning $ UnquotedString $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"
conn' <- fst <$> liftIO (closeP2PSshConnection conn) conn' <- fst <$> liftIO (closeP2PSshConnection conn)
return (conn', Nothing) return (conn', Nothing)

4
Remote/Hook.hs
View file

@ -128,7 +128,7 @@ lookupHook hookname action = do
fallback <- fromConfigValue <$> getConfig hookfallback mempty fallback <- fromConfigValue <$> getConfig hookfallback mempty
if null fallback if null fallback
then do then do
warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback warning $ UnquotedString $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback
return Nothing return Nothing
else return $ Just fallback else return $ Just fallback
else return $ Just command else return $ Just command
@ -153,7 +153,7 @@ runHook' hook action k f a = maybe (return False) run =<< lookupHook hook action
ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f)) ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f))
( a ( a
, do , do
warning $ hook ++ " hook exited nonzero!" warning $ UnquotedString $ hook ++ " hook exited nonzero!"
return False return False
) )

8
Remote/P2P.hs
View file

@ -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.P2P ( module Remote.P2P (
remote, remote,
chainGen chainGen
@ -105,7 +107,7 @@ runProtoConn a c@(OpenConnection (runst, conn)) = do
-- so close it. -- so close it.
case v of case v of
Left e -> do Left e -> do
warning $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")" warning $ UnquotedString $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")"
liftIO $ closeConnection conn liftIO $ closeConnection conn
return (ClosedConnection, Nothing) return (ClosedConnection, Nothing)
Right r -> return (c, Just r) Right r -> return (c, Just r)
@ -163,9 +165,9 @@ openConnection u addr = do
liftIO $ closeConnection conn liftIO $ closeConnection conn
return ClosedConnection return ClosedConnection
Left e -> do Left e -> do
warning $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")" warning $ UnquotedString $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")"
liftIO $ closeConnection conn liftIO $ closeConnection conn
return ClosedConnection return ClosedConnection
Left e -> do Left e -> do
warning $ "Unable to connect to peer. (" ++ show e ++ ")" warning $ UnquotedString $ "Unable to connect to peer. (" ++ show e ++ ")"
return ClosedConnection return ClosedConnection

10
Remote/S3.hs
View file

@ -423,13 +423,13 @@ retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case
Right h -> Right h ->
eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning (UnquotedString failreason)
giveup "cannot download content" giveup "cannot download content"
Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv
Left S3HandleNeedCreds -> Left S3HandleNeedCreds ->
getPublicWebUrls' (uuid r) rs info c k >>= \case getPublicWebUrls' (uuid r) rs info c k >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning (UnquotedString failreason)
giveup "cannot download content" giveup "cannot download content"
Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $
giveup "failed to download content" giveup "failed to download content"
@ -470,13 +470,13 @@ checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig ->
checkKey hv r rs c info k = withS3Handle hv $ \case checkKey hv r rs c info k = withS3Handle hv $ \case
Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning (UnquotedString failreason)
giveup "cannot check content" giveup "cannot check content"
Right loc -> checkKeyHelper info h loc Right loc -> checkKeyHelper info h loc
Left S3HandleNeedCreds -> Left S3HandleNeedCreds ->
getPublicWebUrls' (uuid r) rs info c k >>= \case getPublicWebUrls' (uuid r) rs info c k >>= \case
Left failreason -> do Left failreason -> do
warning failreason warning (UnquotedString failreason)
giveup "cannot check content" giveup "cannot check content"
Right us -> do Right us -> do
let check u = withUrlOptions $ let check u = withUrlOptions $
@ -865,7 +865,7 @@ data S3HandleProblem
giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a
giveupS3HandleProblem S3HandleNeedCreds u = do giveupS3HandleProblem S3HandleNeedCreds u = do
warning $ needS3Creds u warning $ UnquotedString $ needS3Creds u
giveup "No S3 credentials configured" giveup "No S3 credentials configured"
giveupS3HandleProblem S3HandleAnonymousOldAws _ = giveupS3HandleProblem S3HandleAnonymousOldAws _ =
giveup "This S3 special remote is configured with signature=anonymous, but git-annex is built with too old a version of the aws library to support that." giveup "This S3 special remote is configured with signature=anonymous, but git-annex is built with too old a version of the aws library to support that."

2
Upgrade/V1.hs
View file

@ -211,7 +211,7 @@ lookupKey1 file = do
Nothing -> do Nothing -> do
unless (null kname || null bname || unless (null kname || null bname ||
not (isLinkToAnnex (toRawFilePath l))) $ not (isLinkToAnnex (toRawFilePath l))) $
warning skip warning (UnquotedString skip)
return Nothing return Nothing
Just backend -> return $ Just (k, backend) Just backend -> return $ Just (k, backend)
where where

2
Upgrade/V5.hs
View file

@ -59,7 +59,7 @@ upgrade automatic = flip catchNonAsync onexception $ do
return UpgradeSuccess return UpgradeSuccess
where where
onexception e = do onexception e = do
warning $ "caught exception: " ++ show e warning $ UnquotedString $ "caught exception: " ++ show e
return UpgradeFailed return UpgradeFailed
-- git before 2.22 would OOM running git status on a large file. -- git before 2.22 would OOM running git status on a large file.

2
Upgrade/V9.hs
View file

@ -29,7 +29,7 @@ upgrade automatic
) )
| otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getRead Annex.force)) | otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getRead Annex.force))
( do ( do
warning $ unlines unsafeupgrade warning $ UnquotedString $ unlines unsafeupgrade
return UpgradeDeferred return UpgradeDeferred
, performUpgrade automatic , performUpgrade automatic
) )

2
doc/todo/terminal_escapes_in_filenames.mdwn
View file

@ -36,7 +36,7 @@ behave more like git.
> Update: Most git-annex commands now quote filenames, due to work on > Update: Most git-annex commands now quote filenames, due to work on
> ActionItem display. `git-annex find`, `git-annex info $file`, > ActionItem display. `git-annex find`, `git-annex info $file`,
> and everywhere filenames get > and everywhere filenames get
> embedded in warnings, info messages, still need to be done. > embedded in info messages still need to be done.
---- ----