filter out control characters in warning messages
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
parent
007e302637
commit
3290a09a70
75 changed files with 259 additions and 229 deletions
|
|
@ -37,14 +37,14 @@ action :: Annex () -> Annex Bool
|
|||
action a = tryNonAsync a >>= \case
|
||||
Right () -> return True
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return False
|
||||
|
||||
verifiedAction :: Annex Verification -> Annex (Bool, Verification)
|
||||
verifiedAction a = tryNonAsync a >>= \case
|
||||
Right v -> return (True, v)
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@ enterAdjustedBranch adj = inRepo Git.Branch.current >>= \case
|
|||
let adjbranch = adjBranch $ originalToAdjusted origbranch adj
|
||||
ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getRead Annex.force) <&&> pure (not (is_branchView origbranch)))
|
||||
( do
|
||||
mapM_ (warning . unwords)
|
||||
mapM_ (warning . UnquotedString . unwords)
|
||||
[ [ "adjusted branch"
|
||||
, Git.Ref.describe adjbranch
|
||||
, "already exists."
|
||||
|
|
@ -343,7 +343,7 @@ adjustedBranchRefreshFull adj origbranch = do
|
|||
restagePointerFiles =<< Annex.gitRepo
|
||||
let adjbranch = originalToAdjusted origbranch adj
|
||||
unlessM (updateAdjustedBranch adj adjbranch origbranch) $
|
||||
warning $ unwords [ "Updating adjusted branch failed." ]
|
||||
warning "Updating adjusted branch failed."
|
||||
|
||||
adjustToCrippledFileSystem :: Annex ()
|
||||
adjustToCrippledFileSystem = do
|
||||
|
|
@ -497,7 +497,7 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
|
|||
Just currcommit ->
|
||||
newcommits >>= go origsha False >>= \case
|
||||
Left e -> do
|
||||
warning e
|
||||
warning (UnquotedString e)
|
||||
return (Nothing, return ())
|
||||
Right newparent -> return
|
||||
( Just newparent
|
||||
|
|
@ -505,7 +505,8 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
|
|||
)
|
||||
Nothing -> return (Nothing, return ())
|
||||
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 ())
|
||||
where
|
||||
(BasisBranch basis) = basisBranch adjbranch
|
||||
|
|
|
|||
|
|
@ -27,7 +27,8 @@ bloomBitsHashes = do
|
|||
accuracy <- bloomAccuracy
|
||||
case safeSuggestSizing capacity (1 / fromIntegral accuracy) of
|
||||
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)
|
||||
return (16777216,23)
|
||||
Right v -> return v
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ import Annex as X (gitRepo, inRepo, fromRepo, calcRepo, calcRepo')
|
|||
import Annex.Locations as X
|
||||
import Annex.Debug as X (fastDebug, debug)
|
||||
import Messages as X
|
||||
import Git.Filename as X
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.IO as X hiding (createPipe)
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Content (
|
||||
inAnnex,
|
||||
|
|
@ -447,7 +448,7 @@ checkSecureHashes' :: Key -> Annex Bool
|
|||
checkSecureHashes' key = checkSecureHashes key >>= \case
|
||||
Nothing -> return True
|
||||
Just msg -> do
|
||||
warning $ msg ++ "to annex objects"
|
||||
warning $ UnquotedString $ msg ++ "to annex objects"
|
||||
return False
|
||||
|
||||
data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
|
||||
|
|
@ -760,9 +761,10 @@ downloadUrl listfailedurls k p iv urls file uo =
|
|||
go [] [] = return False
|
||||
go [] errs@((_, err):_) = do
|
||||
if listfailedurls
|
||||
then warning $ unlines $ flip map errs $ \(u, err') ->
|
||||
u ++ " " ++ err'
|
||||
else warning err
|
||||
then warning $ UnquotedString $
|
||||
unlines $ flip map errs $ \(u, err') ->
|
||||
u ++ " " ++ err'
|
||||
else warning $ UnquotedString err
|
||||
return False
|
||||
|
||||
{- Copies a key's content, when present, to a temp file.
|
||||
|
|
|
|||
|
|
@ -126,7 +126,8 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRea
|
|||
let delta = need + reserve - have - alreadythere + inprogress
|
||||
let ok = delta <= 0
|
||||
unless ok $
|
||||
warning $ needMoreDiskSpace delta
|
||||
warning $ UnquotedString $
|
||||
needMoreDiskSpace delta
|
||||
return ok
|
||||
_ -> return True
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Difference (
|
||||
module Types.Difference,
|
||||
setDifferences,
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ import Types
|
|||
import Types.Key
|
||||
import qualified Git
|
||||
import qualified Types.Remote as Remote
|
||||
import Git.Filename
|
||||
import Messages
|
||||
|
||||
import Data.Maybe
|
||||
|
|
@ -63,7 +64,7 @@ warnExportImportConflict r = do
|
|||
(False, True) -> ("imported from", "git-annex import")
|
||||
(True, False) -> ("exported to", "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"
|
||||
, ops, Remote.name r ++ ". Use"
|
||||
, resolvcmd
|
||||
|
|
|
|||
|
|
@ -66,7 +66,8 @@ hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
|
|||
hookWarning :: Git.Hook -> String -> Annex ()
|
||||
hookWarning h msg = do
|
||||
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,
|
||||
- the existing hooks are cached. -}
|
||||
|
|
@ -84,4 +85,4 @@ runAnnexHook hook = do
|
|||
where
|
||||
run = unlessM (inRepo $ Git.runHook hook) $ do
|
||||
h <- fromRepo $ Git.hookFile hook
|
||||
warning $ h ++ " failed"
|
||||
warning $ UnquotedString $ h ++ " failed"
|
||||
|
|
|
|||
|
|
@ -510,7 +510,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
|
|||
showNote "old version"
|
||||
tryNonAsync (importordownload cidmap db i largematcher) >>= \case
|
||||
Left e -> next $ do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
liftIO $ atomically $
|
||||
putTMVar job Nothing
|
||||
return False
|
||||
|
|
@ -535,7 +535,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
|
|||
return $ Just (loc, Right k)
|
||||
Right Nothing -> return Nothing
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return Nothing
|
||||
|
||||
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 _ -> return Nothing
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return Nothing
|
||||
where
|
||||
importer = do
|
||||
|
|
@ -634,7 +634,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
|
|||
tryNonAsync (downloader tmpfile) >>= \case
|
||||
Right sha -> return $ Just (loc, Left sha)
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return Nothing
|
||||
where
|
||||
tmpkey = importKey cid sz
|
||||
|
|
@ -662,7 +662,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
|
|||
Right (v, True) -> return $ Just (loc, v)
|
||||
Right (_, False) -> return Nothing
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return Nothing
|
||||
let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote)
|
||||
checkDiskSpaceToGet tmpkey Nothing $
|
||||
|
|
|
|||
|
|
@ -48,7 +48,6 @@ import Utility.CopyFile
|
|||
import Utility.Touch
|
||||
import Utility.Metered
|
||||
import Git.FilePath
|
||||
import Git.Filename
|
||||
import Annex.InodeSentinal
|
||||
import Annex.AdjustedBranch
|
||||
import Annex.FileMatcher
|
||||
|
|
@ -88,7 +87,7 @@ data LockDownConfig = LockDownConfig
|
|||
-}
|
||||
lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown)
|
||||
lockDown cfg file = either
|
||||
(\e -> warning (show e) >> return Nothing)
|
||||
(\e -> warning (UnquotedString (show e)) >> return Nothing)
|
||||
(return . Just)
|
||||
=<< lockDown' cfg file
|
||||
|
||||
|
|
@ -227,7 +226,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
|
|||
return (Just k, mcache)
|
||||
|
||||
failure msg = do
|
||||
warning $ fromRawFilePath (keyFilename source) ++ " " ++ msg
|
||||
warning $ QuotedPath (keyFilename source) <> " " <> UnquotedString msg
|
||||
cleanCruft source
|
||||
return (Nothing, Nothing)
|
||||
|
||||
|
|
@ -299,7 +298,7 @@ restoreFile file key e = do
|
|||
-- content in the annex, and make a copy back to the file.
|
||||
obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key)
|
||||
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
|
||||
throwM e
|
||||
|
||||
|
|
@ -412,11 +411,10 @@ addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a
|
|||
addingExistingLink f k a = do
|
||||
unlessM (isKnownKey k <||> inAnnex k) $ do
|
||||
islink <- isJust <$> isAnnexLink f
|
||||
warning $ unwords
|
||||
[ fromRawFilePath f
|
||||
, "is a git-annex"
|
||||
, if islink then "symlink." else "pointer file."
|
||||
, "Its content is not available in this repository."
|
||||
, "(Maybe " ++ fromRawFilePath f ++ " was copied from another repository?)"
|
||||
]
|
||||
warning $
|
||||
QuotedPath f
|
||||
<> " is a git-annex "
|
||||
<> if islink then "symlink." else "pointer file."
|
||||
<> " Its content is not available in this repository."
|
||||
<> " (Maybe " <> QuotedPath f <> " was copied from another repository?)"
|
||||
a
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case
|
|||
Just noannexmsg -> do
|
||||
warning "Initialization prevented by .noannex file (remove the file to override)"
|
||||
unless (null noannexmsg) $
|
||||
warning noannexmsg
|
||||
warning (UnquotedString noannexmsg)
|
||||
giveup "Not initialized."
|
||||
|
||||
initializeAllowed :: Annex Bool
|
||||
|
|
@ -272,7 +272,7 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
|
|||
(Just (freezeContent' UnShared))
|
||||
(Just (thawContent' UnShared))
|
||||
=<< hasFreezeHook
|
||||
mapM_ warning warnings
|
||||
mapM_ (warning . UnquotedString) warnings
|
||||
return r
|
||||
|
||||
probeCrippledFileSystem'
|
||||
|
|
|
|||
|
|
@ -186,7 +186,7 @@ newtype Restage = Restage Bool
|
|||
restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex ()
|
||||
restagePointerFile (Restage False) f orig = do
|
||||
flip writeRestageLog orig =<< inRepo (toTopFilePath f)
|
||||
toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f
|
||||
toplevelWarning True $ unableToRestage $ Just f
|
||||
restagePointerFile (Restage True) f orig = do
|
||||
flip writeRestageLog orig =<< inRepo (toTopFilePath f)
|
||||
-- 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"
|
||||
ckd = ConfigKey "filter.annex.process-temp-disabled"
|
||||
|
||||
unableToRestage :: Maybe FilePath -> String
|
||||
unableToRestage mf = unwords
|
||||
[ "git status will show " ++ fromMaybe "some files" mf
|
||||
, "to be modified, since content availability has changed"
|
||||
, "and git-annex was unable to update the index."
|
||||
, "This is only a cosmetic problem affecting git status; git add,"
|
||||
, "git commit, etc won't be affected."
|
||||
, "To fix the git status display, you can run:"
|
||||
, "git-annex restage"
|
||||
]
|
||||
unableToRestage :: Maybe RawFilePath -> StringContainingQuotedPath
|
||||
unableToRestage mf =
|
||||
"git status will show " <> maybe "some files" QuotedPath mf
|
||||
<> " to be modified, since content availability has changed"
|
||||
<> " and git-annex was unable to update the index."
|
||||
<> " This is only a cosmetic problem affecting git status; git add,"
|
||||
<> " git commit, etc won't be affected."
|
||||
<> " To fix the git status display, you can run:"
|
||||
<> " git-annex restage"
|
||||
|
||||
{- Parses a symlink target or a pointer file to a Key.
|
||||
-
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ import Utility.LockPool.STM (LockFile, LockMode(..))
|
|||
import Utility.LockFile.LockStatus
|
||||
import Config (pidLockFile)
|
||||
import Messages (warning)
|
||||
import Git.Filename
|
||||
|
||||
import System.Posix
|
||||
|
||||
|
|
@ -74,7 +75,7 @@ pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile
|
|||
go (Just pidlock) = do
|
||||
timeout <- annexPidLockTimeout <$> Annex.getGitConfig
|
||||
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 m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ genMetaData key file mmtime = do
|
|||
dateMetaData (posixSecondsToUTCTime mtime) old
|
||||
Nothing -> noop
|
||||
where
|
||||
warncopied = warning $
|
||||
warncopied = warning $ UnquotedString $
|
||||
"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 the only fields copied were date metadata, and they'll
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ autoEnable = do
|
|||
showSideAction $ "Auto enabling special remote " ++ name
|
||||
dummycfg <- liftIO dummyRemoteGitConfig
|
||||
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) ->
|
||||
when (cu /= u) $
|
||||
setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)
|
||||
|
|
|
|||
|
|
@ -120,8 +120,8 @@ sshCachingInfo (host, port) = go =<< sshCacheDir'
|
|||
|
||||
warnnocaching whynocaching =
|
||||
whenM (annexAdviceNoSshCaching <$> Annex.getGitConfig) $ do
|
||||
warning nocachingwarning
|
||||
warning whynocaching
|
||||
warning $ UnquotedString nocachingwarning
|
||||
warning $ UnquotedString whynocaching
|
||||
|
||||
nocachingwarning = unwords
|
||||
[ "You have enabled concurrency, but git-annex is not able"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
{-# LANGUAGE CPP, BangPatterns, OverloadedStrings #-}
|
||||
|
||||
module Annex.Transfer (
|
||||
module X,
|
||||
|
|
@ -200,7 +200,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
|
|||
| observeBool v -> return v
|
||||
| otherwise -> checkretry
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
checkretry
|
||||
where
|
||||
checkretry = do
|
||||
|
|
@ -289,7 +289,7 @@ preCheckSecureHashes k meventualbackend a = case meventualbackend of
|
|||
)
|
||||
)
|
||||
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
|
||||
|
||||
type NumRetries = Integer
|
||||
|
|
|
|||
|
|
@ -6,6 +6,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Url (
|
||||
withUrlOptions,
|
||||
withUrlOptionsPromptingCreds,
|
||||
|
|
@ -166,13 +168,13 @@ checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool
|
|||
checkBoth url expected_size uo =
|
||||
liftIO (U.checkBoth url expected_size uo) >>= \case
|
||||
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 iv url file uo =
|
||||
liftIO (U.download meterupdate iv url file uo) >>= \case
|
||||
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 iv url file uo =
|
||||
|
|
@ -181,7 +183,7 @@ download' meterupdate iv url file uo =
|
|||
exists :: U.URLString -> U.UrlOptions -> Annex Bool
|
||||
exists url uo = liftIO (U.exists url uo) >>= \case
|
||||
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 url uo = liftIO (U.getUrlInfo url uo)
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Verify (
|
||||
shouldVerify,
|
||||
|
|
@ -152,7 +153,7 @@ verifyKeySize k f = case fromKey keySize k of
|
|||
Nothing -> return True
|
||||
|
||||
warnUnverifiableInsecure :: Key -> Annex ()
|
||||
warnUnverifiableInsecure k = warning $ unwords
|
||||
warnUnverifiableInsecure k = warning $ UnquotedString $ unwords
|
||||
[ "Getting " ++ kv ++ " keys with this remote is not secure;"
|
||||
, "the content cannot be verified to be correct."
|
||||
, "(Use annex.security.allow-unverified-downloads to bypass"
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ youtubeDlTo key url dest p = do
|
|||
return (Just True)
|
||||
Right Nothing -> return (Just False)
|
||||
Left msg -> do
|
||||
warning msg
|
||||
warning (UnquotedString msg)
|
||||
return Nothing
|
||||
return (fromMaybe False res)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, OverloadedStrings #-}
|
||||
|
||||
module Assistant.Threads.Committer where
|
||||
|
||||
|
|
@ -433,8 +433,8 @@ safeToAdd lockdowndir lockdownconfig havelsof delayadd pending inprocess = do
|
|||
|
||||
canceladd (InProcessAddChange { lockedDown = ld }) = do
|
||||
let ks = keySource ld
|
||||
warning $ fromRawFilePath (keyFilename ks)
|
||||
++ " still has writers, not adding"
|
||||
warning $ QuotedPath (keyFilename ks)
|
||||
<> " still has writers, not adding"
|
||||
-- remove the hard link
|
||||
when (contentLocation ks /= keyFilename ks) $
|
||||
void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ dbusThread urlrenderer = do
|
|||
onerr :: E.SomeException -> Assistant ()
|
||||
onerr e = do
|
||||
liftAnnex $
|
||||
warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
|
||||
warning $ UnquotedString $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"
|
||||
pollingThread urlrenderer
|
||||
|
||||
{- Examine the list of services connected to dbus, to see if there
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ dbusThread = do
|
|||
sendRemoteControl RESUME
|
||||
onerr e _ = do
|
||||
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 -}
|
||||
liftIO $ threadDelaySeconds (Seconds 60)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Assistant.Threads.PairListener where
|
||||
|
||||
import Assistant.Common
|
||||
|
|
@ -49,7 +51,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
|
|||
debug ["ignoring message that looped back"]
|
||||
go reqs cache sock
|
||||
(_, _, False, _) -> do
|
||||
liftAnnex $ warning $
|
||||
liftAnnex $ warning $ UnquotedString $
|
||||
"illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")"
|
||||
go reqs cache sock
|
||||
-- PairReq starts a pairing process, so a
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ sanityCheckerDailyThread urlrenderer = namedThread "SanityCheckerDaily" $ foreve
|
|||
return r
|
||||
|
||||
showerr e = do
|
||||
liftAnnex $ warning $ show e
|
||||
liftAnnex $ warning $ UnquotedString $ show e
|
||||
return False
|
||||
|
||||
{- 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)
|
||||
slop = fromIntegral tenMinutes
|
||||
insanity msg = do
|
||||
liftAnnex $ warning msg
|
||||
liftAnnex $ warning (UnquotedString msg)
|
||||
void $ addAlert $ sanityCheckFixAlert msg
|
||||
addsymlink file s = do
|
||||
Watcher.runHandler Watcher.onAddSymlink file s
|
||||
|
|
|
|||
|
|
@ -184,7 +184,7 @@ runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
|
|||
runHandler handler file filestatus = void $ do
|
||||
r <- tryIO <~> handler (normalize file) filestatus
|
||||
case r of
|
||||
Left e -> liftAnnex $ warning $ show e
|
||||
Left e -> liftAnnex $ warning $ UnquotedString $ show e
|
||||
Right Nothing -> noop
|
||||
Right (Just change) -> recordChange change
|
||||
where
|
||||
|
|
@ -371,6 +371,6 @@ onDelDir dir _ = do
|
|||
{- Called when there's an error with inotify or kqueue. -}
|
||||
onErr :: Handler
|
||||
onErr msg _ = do
|
||||
liftAnnex $ warning msg
|
||||
liftAnnex $ warning (UnquotedString msg)
|
||||
void $ addAlert $ warningAlert "watcher" msg
|
||||
noChange
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Backend (
|
||||
builtinList,
|
||||
defaultBackend,
|
||||
|
|
@ -66,7 +68,8 @@ getBackend :: FilePath -> Key -> Annex (Maybe Backend)
|
|||
getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case
|
||||
Just backend -> return $ Just backend
|
||||
Nothing -> do
|
||||
warning $ "skipping " ++ file ++ " (" ++ unknownBackendVarietyMessage (fromKey keyVariety k) ++ ")"
|
||||
warning $ "skipping " <> QuotedPath (toRawFilePath file) <> " (" <>
|
||||
UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")"
|
||||
return Nothing
|
||||
|
||||
unknownBackendVarietyMessage :: KeyVariety -> String
|
||||
|
|
|
|||
|
|
@ -139,7 +139,8 @@ handleRequest st req whenunavail responsehandler =
|
|||
loop
|
||||
where
|
||||
handleExceptionalMessage _ (ERROR err) = do
|
||||
warning ("external special remote error: " ++ err)
|
||||
warning $ UnquotedString $
|
||||
"external special remote error: " ++ err
|
||||
whenunavail
|
||||
handleExceptionalMessage loop (DEBUG msg) = do
|
||||
fastDebug "Backend.External" msg
|
||||
|
|
@ -237,7 +238,7 @@ newExternalState ebname hasext pid = do
|
|||
where
|
||||
basecmd = externalBackendProgram ebname
|
||||
warnonce msg = when (pid == 1) $
|
||||
warning msg
|
||||
warning (UnquotedString msg)
|
||||
|
||||
externalBackendProgram :: ExternalBackendName -> String
|
||||
externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname
|
||||
|
|
|
|||
|
|
@ -130,7 +130,7 @@ checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do
|
|||
_ -> return True
|
||||
where
|
||||
hwfault e = do
|
||||
warning $ "hardware fault: " ++ show e
|
||||
warning $ UnquotedString $ "hardware fault: " ++ show e
|
||||
return False
|
||||
|
||||
sameCheckSum :: Key -> String -> Bool
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ accountCommandAction startmsg cleanup = tryNonAsync cleanup >>= \case
|
|||
Left err -> case fromException err of
|
||||
Just exitcode -> liftIO $ exitWith exitcode
|
||||
Nothing -> do
|
||||
toplevelWarning True (show err)
|
||||
toplevelWarning True (UnquotedString (show err))
|
||||
showEndMessage startmsg False
|
||||
incerr
|
||||
where
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
|
||||
|
||||
module CmdLine.GitAnnex.Options where
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module CmdLine.Seek where
|
||||
|
||||
import Annex.Common
|
||||
|
|
@ -566,9 +568,9 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
|
|||
let p' = toRawFilePath p
|
||||
relf <- liftIO $ relPathCwdToFile p'
|
||||
ifM (not <$> (exists p' <||> hidden currbranch relf))
|
||||
( prob (p ++ " not found")
|
||||
( prob (QuotedPath (toRawFilePath p) <> " not found")
|
||||
, ifM (viasymlink stopattop (upFrom relf))
|
||||
( prob (p ++ " is beyond a symbolic link")
|
||||
( prob (QuotedPath (toRawFilePath p) <> " is beyond a symbolic link")
|
||||
, return True
|
||||
)
|
||||
)
|
||||
|
|
@ -628,7 +630,7 @@ mkCheckTimeLimit = Annex.getState Annex.timelimit >>= \case
|
|||
swapTVar warningshownv True
|
||||
unless warningshown $ do
|
||||
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
|
||||
else a
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,6 @@ import Messages.Progress
|
|||
import Git.FilePath
|
||||
import Git.Types
|
||||
import Git.UpdateIndex
|
||||
import Git.Filename
|
||||
import Config.GitConfig
|
||||
import Utility.OptParse
|
||||
import Utility.InodeCache
|
||||
|
|
@ -175,7 +174,7 @@ addFile smallorlarge file s = do
|
|||
s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file
|
||||
if maybe True (changed s) s'
|
||||
then do
|
||||
warning $ fromRawFilePath file ++ " changed while it was being added"
|
||||
warning $ QuotedPath file <> " changed while it was being added"
|
||||
return False
|
||||
else do
|
||||
case smallorlarge of
|
||||
|
|
|
|||
|
|
@ -34,7 +34,6 @@ import Utility.Metered
|
|||
import Utility.HtmlDetect
|
||||
import Utility.Path.Max
|
||||
import Utility.Url (parseURIPortable)
|
||||
import Git.Filename
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Annex.Transfer as Transfer
|
||||
|
||||
|
|
@ -154,7 +153,7 @@ checkUrl addunlockedmatcher r o si u = do
|
|||
where
|
||||
|
||||
go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
next $ return False
|
||||
go deffile (Right (UrlContents sz mf)) = do
|
||||
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
|
||||
Right urlinfo -> go' url urlinfo
|
||||
Left err -> do
|
||||
warning err
|
||||
warning (UnquotedString err)
|
||||
next $ return False
|
||||
go' url urlinfo = do
|
||||
pathmax <- liftIO $ fileNameLengthLimit "."
|
||||
|
|
@ -306,7 +305,7 @@ addUrlChecked o url file u checkexistssize key =
|
|||
logChange key u InfoPresent
|
||||
next $ return True
|
||||
| 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
|
||||
else "failed to verify url exists: " ++ url
|
||||
stop
|
||||
|
|
@ -347,7 +346,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
Right mediafile ->
|
||||
let f = youtubeDlDestFile o file (toRawFilePath mediafile)
|
||||
in lookupKey f >>= \case
|
||||
Just k -> alreadyannexed (fromRawFilePath f) k
|
||||
Just k -> alreadyannexed f k
|
||||
Nothing -> dl f
|
||||
Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend)
|
||||
where
|
||||
|
|
@ -366,7 +365,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
|
||||
Left msg -> do
|
||||
cleanuptmp
|
||||
warning msg
|
||||
warning (UnquotedString msg)
|
||||
return Nothing
|
||||
mediaurl = setDownloader url YoutubeDownloader
|
||||
mediakey = Backend.URL.fromUrl mediaurl Nothing
|
||||
|
|
@ -377,13 +376,13 @@ downloadWeb addunlockedmatcher o url urlinfo file =
|
|||
if mediaurl `elem` us
|
||||
then return (Just k)
|
||||
else do
|
||||
warning $ dest ++ " already exists; not overwriting"
|
||||
warning $ QuotedPath dest <> " already exists; not overwriting"
|
||||
return Nothing
|
||||
|
||||
checkRaw :: (Maybe String) -> DownloadOptions -> a -> Annex a -> Annex a
|
||||
checkRaw failreason o f a
|
||||
| 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
|
||||
Just msg -> ": " ++ msg
|
||||
Nothing -> ""
|
||||
|
|
@ -507,7 +506,7 @@ nodownloadWeb addunlockedmatcher o url urlinfo file
|
|||
Right mediafile -> usemedia (toRawFilePath mediafile)
|
||||
Left err -> checkRaw (Just err) o Nothing nomedia
|
||||
| otherwise = do
|
||||
warning $ "unable to access url: " ++ url
|
||||
warning $ UnquotedString $ "unable to access url: " ++ url
|
||||
return Nothing
|
||||
where
|
||||
nomedia = do
|
||||
|
|
@ -565,11 +564,11 @@ data CanAddFile = CanAddFile
|
|||
checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
|
||||
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file))
|
||||
( do
|
||||
warning $ fromRawFilePath file ++ " already exists; not overwriting"
|
||||
warning $ QuotedPath file <> " already exists; not overwriting"
|
||||
return Nothing
|
||||
, ifM (checkIgnored (checkGitIgnoreOption o) file)
|
||||
( 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
|
||||
, a CanAddFile
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.DropUnused where
|
||||
|
||||
import Command
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ checkHiddenService = bracket setup cleanup go
|
|||
-- we just want to know if the tor circuit works.
|
||||
liftIO (tryNonAsync $ connectPeer g addr) >>= \case
|
||||
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)
|
||||
check (n-1) addrs
|
||||
Right conn -> do
|
||||
|
|
|
|||
|
|
@ -435,7 +435,7 @@ performRename r db ek src dest =
|
|||
tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case
|
||||
Right (Just ()) -> next $ cleanupRename r db ek src dest
|
||||
Left err -> do
|
||||
warning $ "rename failed (" ++ show err ++ "); deleting instead"
|
||||
warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead"
|
||||
fallbackdelete
|
||||
-- remote does not support renaming
|
||||
Right Nothing -> fallbackdelete
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.FromKey where
|
||||
|
||||
import Command
|
||||
|
|
@ -130,7 +132,7 @@ perform matcher key file = lookupKeyNotHidden file >>= \case
|
|||
| otherwise -> hasothercontent
|
||||
where
|
||||
hasothercontent = do
|
||||
warning $ fromRawFilePath file ++ " already exists with different content"
|
||||
warning $ QuotedPath file <> " already exists with different content"
|
||||
next $ return False
|
||||
|
||||
linkunlocked = linkFromAnnex key file Nothing >>= \case
|
||||
|
|
|
|||
|
|
@ -167,7 +167,7 @@ performRemote key afile backend numcopies remote =
|
|||
Just (Right verification) -> go True (Just (tmpfile, verification))
|
||||
Just (Left _) -> do
|
||||
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
|
||||
return False
|
||||
dispatch (Right False) = go False Nothing
|
||||
|
|
@ -320,7 +320,7 @@ verifyLocationLog key keystatus ai = do
|
|||
KeyLockedThin -> thawContent obj
|
||||
_ -> freezeContent obj
|
||||
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 ()
|
||||
whenM (liftIO $ R.doesPathExist $ parentDir obj) $
|
||||
freezeContentDir obj
|
||||
|
|
@ -331,7 +331,7 @@ verifyLocationLog key keystatus ai = do
|
|||
- config was set. -}
|
||||
whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $
|
||||
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)
|
||||
|
||||
|
|
@ -352,9 +352,9 @@ verifyLocationLog' key ai present u updatestatus = do
|
|||
fix InfoMissing
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
warning $
|
||||
"** Based on the location log, " ++
|
||||
decodeBS (actionItemDesc qp ai) ++
|
||||
"\n** was expected to be present, " ++
|
||||
"** Based on the location log, " <>
|
||||
QuotedPath (actionItemDesc qp ai) <>
|
||||
"\n** was expected to be present, " <>
|
||||
"but its content is missing."
|
||||
return False
|
||||
(False, False) -> do
|
||||
|
|
@ -393,10 +393,10 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
|
|||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
|
||||
warning $
|
||||
"** Required content " ++
|
||||
decodeBS (actionItemDesc qp ai) ++
|
||||
" is missing from these repositories:\n" ++
|
||||
missingrequired
|
||||
"** Required content " <>
|
||||
QuotedPath (actionItemDesc qp ai) <>
|
||||
" is missing from these repositories:\n" <>
|
||||
UnquotedString missingrequired
|
||||
return False
|
||||
verifyRequiredContent _ _ = return True
|
||||
|
||||
|
|
@ -468,13 +468,12 @@ checkKeySizeOr bad key file ai = case fromKey keySize key of
|
|||
badsize a b = do
|
||||
msg <- bad key
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
warning $ concat
|
||||
[ decodeBS (actionItemDesc qp ai)
|
||||
, ": Bad file size ("
|
||||
, compareSizes storageUnits True a b
|
||||
, "); "
|
||||
, msg
|
||||
]
|
||||
warning $
|
||||
QuotedPath (actionItemDesc qp ai)
|
||||
<> ": Bad file size ("
|
||||
<> UnquotedString (compareSizes storageUnits True a b)
|
||||
<> "); "
|
||||
<> UnquotedString msg
|
||||
|
||||
{- Check for keys that are upgradable.
|
||||
-
|
||||
|
|
@ -487,13 +486,13 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
|
|||
case Types.Backend.canUpgradeKey backend of
|
||||
Just a | a key -> do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
warning $ concat
|
||||
[ decodeBS (actionItemDesc qp ai)
|
||||
, ": Can be upgraded to an improved key format. "
|
||||
, "You can do so by running: git annex migrate --backend="
|
||||
, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " "
|
||||
, decodeBS file
|
||||
]
|
||||
warning $
|
||||
QuotedPath (actionItemDesc qp ai)
|
||||
<> ": Can be upgraded to an improved key format. "
|
||||
<> "You can do so by running: git annex migrate --backend="
|
||||
<> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key)))
|
||||
<> " "
|
||||
<> QuotedPath file
|
||||
return True
|
||||
_ -> return True
|
||||
checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =
|
||||
|
|
@ -539,11 +538,10 @@ checkBackendOr bad backend key file ai =
|
|||
unless ok $ do
|
||||
msg <- bad key
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
warning $ concat
|
||||
[ decodeBS (actionItemDesc qp ai)
|
||||
, ": Bad file content; "
|
||||
, msg
|
||||
]
|
||||
warning $
|
||||
QuotedPath (actionItemDesc qp ai)
|
||||
<> ": Bad file content; "
|
||||
<> UnquotedString msg
|
||||
return ok
|
||||
Nothing -> return True
|
||||
|
||||
|
|
@ -568,17 +566,16 @@ checkInodeCache key content mic ai = case mic of
|
|||
Nothing -> noop
|
||||
Just ic' -> whenM (compareInodeCaches ic ic') $ do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
warning $ concat
|
||||
[ decodeBS (actionItemDesc qp ai)
|
||||
, ": Stale or missing inode cache; updating."
|
||||
]
|
||||
warning $
|
||||
QuotedPath (actionItemDesc qp ai)
|
||||
<> ": Stale or missing inode cache; updating."
|
||||
Database.Keys.addInodeCaches key [ic]
|
||||
|
||||
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
|
||||
checkKeyNumCopies key afile numcopies = do
|
||||
let (desc, hasafile) = case afile of
|
||||
AssociatedFile Nothing -> (serializeKey key, False)
|
||||
AssociatedFile (Just af) -> (fromRawFilePath af, True)
|
||||
AssociatedFile Nothing -> (serializeKey' key, False)
|
||||
AssociatedFile (Just af) -> (af, True)
|
||||
locs <- loggedLocations key
|
||||
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
|
||||
(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations
|
||||
|
|
@ -598,21 +595,21 @@ checkKeyNumCopies key afile numcopies = do
|
|||
)
|
||||
else return True
|
||||
|
||||
missingNote :: String -> Int -> NumCopies -> String -> String -> String
|
||||
missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath
|
||||
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 =
|
||||
"Only these untrusted locations may have copies of " ++ file ++
|
||||
"\n" ++ untrusted ++
|
||||
"Back it up to trusted locations with git-annex copy." ++ honorDead dead
|
||||
"Only these untrusted locations may have copies of " <> QuotedPath file <>
|
||||
"\n" <> UnquotedString untrusted <>
|
||||
"Back it up to trusted locations with git-annex copy." <> UnquotedString (honorDead dead)
|
||||
missingNote file present needed [] _ =
|
||||
"Only " ++ show present ++ " of " ++ show (fromNumCopies needed) ++
|
||||
" trustworthy copies exist of " ++ file ++
|
||||
"Only " <> UnquotedString (show present) <> " of " <> UnquotedString (show (fromNumCopies needed)) <>
|
||||
" trustworthy copies exist of " <> QuotedPath file <>
|
||||
"\nBack it up with git-annex copy."
|
||||
missingNote file present needed untrusted dead =
|
||||
missingNote file present needed [] dead ++
|
||||
"\nThe following untrusted locations may also have copies: " ++
|
||||
"\n" ++ untrusted
|
||||
missingNote file present needed [] dead <>
|
||||
"\nThe following untrusted locations may also have copies: " <>
|
||||
"\n" <> UnquotedString untrusted
|
||||
|
||||
honorDead :: String -> String
|
||||
honorDead dead
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@ import Annex.RemoteTrackingBranch
|
|||
import Utility.InodeCache
|
||||
import Logs.Location
|
||||
import Git.FilePath
|
||||
import Git.Filename
|
||||
import Git.Types
|
||||
import Types.Import
|
||||
import Utility.Metered
|
||||
|
|
@ -171,7 +170,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
ignored <- checkIgnored (checkGitIgnoreOption o) destfile
|
||||
if ignored
|
||||
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
|
||||
else do
|
||||
existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)
|
||||
|
|
@ -199,7 +198,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
Just s
|
||||
| isDirectory s -> cont
|
||||
| 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
|
||||
|
||||
importfilechecked ld k = do
|
||||
|
|
@ -257,7 +256,7 @@ startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =
|
|||
, Command.Add.addSmall (DryRun False) destfile s
|
||||
)
|
||||
notoverwriting why = do
|
||||
warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why
|
||||
warning $ "not overwriting existing " <> QuotedPath destfile <> " " <> UnquotedString why
|
||||
stop
|
||||
lockdown a = do
|
||||
let mi = MatchingFile $ FileInfo
|
||||
|
|
@ -335,7 +334,7 @@ seekRemote remote branch msubdir importcontent ci = do
|
|||
liftIO (atomically (readTVar importabletvar)) >>= \case
|
||||
Nothing -> return ()
|
||||
Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case
|
||||
Nothing -> warning $ concat
|
||||
Nothing -> warning $ UnquotedString $ concat
|
||||
[ "Failed to import some files from "
|
||||
, Remote.name remote
|
||||
, ". Re-run command to resume import."
|
||||
|
|
@ -388,5 +387,5 @@ commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig
|
|||
setRemoteTrackingBranch tb c
|
||||
return True
|
||||
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
|
||||
|
|
|
|||
|
|
@ -228,7 +228,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio
|
|||
else Url.withUrlOptions (Url.getUrlInfo url) >>= \case
|
||||
Right urlinfo -> go urlinfo
|
||||
Left err -> do
|
||||
warning err
|
||||
warning (UnquotedString err)
|
||||
return (Just [])
|
||||
else do
|
||||
res <- tryNonAsync $ maybe
|
||||
|
|
@ -349,7 +349,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio
|
|||
-- an enclosure.
|
||||
Right Nothing -> Just <$> downloadlink True
|
||||
Left msg -> do
|
||||
warning $ linkurl ++ ": " ++ msg
|
||||
warning $ UnquotedString $ linkurl ++ ": " ++ msg
|
||||
return Nothing
|
||||
return (fromMaybe False r)
|
||||
, downloadlink False
|
||||
|
|
@ -477,10 +477,10 @@ noneValue = "none"
|
|||
feedProblem :: URLString -> String -> Annex Bool
|
||||
feedProblem url message = ifM (checkFeedBroken url)
|
||||
( do
|
||||
warning $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
|
||||
warning $ UnquotedString $ message ++ " (having repeated problems with feed: " ++ url ++ ")"
|
||||
return False
|
||||
, do
|
||||
warning $ "warning: " ++ message
|
||||
warning $ UnquotedString $ "warning: " ++ message
|
||||
return True
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP, OverloadedStrings #-}
|
||||
|
||||
module Command.Multicast where
|
||||
|
||||
|
|
@ -211,7 +211,7 @@ storeReceived :: FilePath -> Annex ()
|
|||
storeReceived f = do
|
||||
case deserializeKey (takeFileName f) of
|
||||
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)
|
||||
Just k -> void $ logStatusAfter k $
|
||||
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ performPairing remotename addrs = do
|
|||
warning "Failed receiving data from pair."
|
||||
return False
|
||||
LinkFailed e -> do
|
||||
warning $ "Failed linking to pair: " ++ e
|
||||
warning $ UnquotedString $ "Failed linking to pair: " ++ e
|
||||
return False
|
||||
where
|
||||
ui observer producer = do
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@ import Annex.ReplaceFile
|
|||
import Logs.Location
|
||||
import Annex.InodeSentinal
|
||||
import Annex.WorkTree
|
||||
import Git.Filename
|
||||
import Utility.InodeCache
|
||||
import qualified Utility.RawFilePath as R
|
||||
|
||||
|
|
@ -118,7 +117,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
|
|||
ic <- withTSDelta (liftIO . genInodeCache file)
|
||||
case v of
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return False
|
||||
Right () -> do
|
||||
r <- linkToAnnex newkey file ic
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ import Utility.Metered
|
|||
import Annex.WorkTree
|
||||
import qualified Git
|
||||
import qualified Annex
|
||||
import Git.Filename
|
||||
|
||||
cmd :: Command
|
||||
cmd = withAnnexOptions [backendOption] $
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.Smudge where
|
||||
|
||||
import Command
|
||||
|
|
@ -142,7 +144,7 @@ clean' file mk passthrough discardreststdin emitpointer =
|
|||
Right Nothing -> notpointer
|
||||
Left InvalidAppendedPointerFile -> do
|
||||
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 = inRepo (Git.Ref.fileRef file) >>= \case
|
||||
|
|
@ -329,5 +331,5 @@ updateSmudged restage = streamSmudged $ \k topf -> do
|
|||
else Database.Keys.addInodeCaches k [ic]
|
||||
Nothing -> liftIO (isPointerFile f) >>= \case
|
||||
Just k' | k' == k -> toplevelWarning False $
|
||||
"unable to populate worktree file " ++ fromRawFilePath f
|
||||
"unable to populate worktree file " <> QuotedPath f
|
||||
_ -> noop
|
||||
|
|
|
|||
|
|
@ -403,7 +403,7 @@ mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \c
|
|||
let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch)
|
||||
let si = SeekInput []
|
||||
starting "merge" ai si $ do
|
||||
warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it."
|
||||
warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it."
|
||||
next $ return False
|
||||
Nothing -> stop
|
||||
|
||||
|
|
@ -533,7 +533,7 @@ importRemote importcontent o remote currbranch
|
|||
-- mergeing it.
|
||||
mc <- mergeConfig True
|
||||
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
|
||||
wantpull = remoteAnnexPull (Remote.gitconfig remote)
|
||||
|
||||
|
|
@ -604,7 +604,7 @@ pushRemote o remote (Just branch, _) = do
|
|||
if ok
|
||||
then postpushupdate repo
|
||||
else do
|
||||
warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
|
||||
warning $ UnquotedString $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]
|
||||
return ok
|
||||
where
|
||||
ai = ActionItemOther (Just (UnquotedString (Remote.name remote)))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,6 @@ import Annex.SpecialRemote.Config (exportTreeField)
|
|||
import Remote.Helper.Chunked
|
||||
import Remote.Helper.Encryptable (encryptionField, highRandomQualityField)
|
||||
import Git.Types
|
||||
import Git.Filename
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.Runners
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ toPerform key file remote = go Upload file $
|
|||
Remote.logStatus remote key InfoPresent
|
||||
return True
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return False
|
||||
|
||||
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
|
||||
Right v -> return (True, v)
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
where
|
||||
vc = RemoteVerify remote
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ start = do
|
|||
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
|
||||
tryNonAsync (Remote.storeKey remote key file p) >>= \case
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return False
|
||||
Right () -> do
|
||||
Remote.logStatus remote key InfoPresent
|
||||
|
|
@ -53,7 +53,7 @@ start = 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
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
Right v -> return (True, v)
|
||||
-- Make sure we get the current
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ start = do
|
|||
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
|
||||
tryNonAsync (Remote.storeKey remote key file p) >>= \case
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return False
|
||||
Right () -> do
|
||||
Remote.logStatus remote key InfoPresent
|
||||
|
|
@ -75,7 +75,7 @@ start = 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
|
||||
Left e -> do
|
||||
warning (show e)
|
||||
warning (UnquotedString (show e))
|
||||
return (False, UnVerified)
|
||||
Right v -> return (True, v)
|
||||
-- Make sure we get the current
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ trustCommand c level ps = withStrings (commandAction . start) ps
|
|||
groupSet uuid S.empty
|
||||
l <- lookupTrust uuid
|
||||
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
|
||||
|
||||
trustedNeedsForce :: String -> String
|
||||
|
|
|
|||
|
|
@ -14,7 +14,6 @@ import Git.DiffTree
|
|||
import Git.FilePath
|
||||
import Git.UpdateIndex
|
||||
import Git.Sha
|
||||
import Git.Filename
|
||||
import qualified Annex
|
||||
import qualified Git.LsFiles as LsFiles
|
||||
import qualified Git.Command as Git
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Command.View where
|
||||
|
||||
import Command
|
||||
|
|
|
|||
|
|
@ -142,7 +142,7 @@ getRemoteUrls key remote
|
|||
Just w -> tryNonAsync (w key) >>= \case
|
||||
Right l -> pure l
|
||||
Left e -> do
|
||||
warning $ unwords
|
||||
warning $ UnquotedString $ unwords
|
||||
[ "unable to query remote"
|
||||
, name remote
|
||||
, "for urls:"
|
||||
|
|
|
|||
2
Creds.hs
2
Creds.hs
|
|
@ -156,7 +156,7 @@ getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredP
|
|||
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
|
||||
where
|
||||
go Nothing = do
|
||||
warning $ missingCredPairFor this storage
|
||||
warning $ UnquotedString $ missingCredPairFor this storage
|
||||
return Nothing
|
||||
go (Just credpair) = return $ Just credpair
|
||||
|
||||
|
|
|
|||
31
Messages.hs
31
Messages.hs
|
|
@ -55,6 +55,7 @@ module Messages (
|
|||
import Control.Concurrent
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
||||
import Common
|
||||
import Types
|
||||
|
|
@ -183,16 +184,16 @@ showOutput = unlessM commandProgressDisabled $
|
|||
outputMessage JSON.none "\n"
|
||||
|
||||
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 = '\n' : indent s ++ "\n"
|
||||
formatLongNote :: S.ByteString -> S.ByteString
|
||||
formatLongNote s = "\n" <> indent s <> "\n"
|
||||
|
||||
-- Used by external special remote, displayed same as showLongNote
|
||||
-- to console, but json object containing the info is emitted immediately.
|
||||
showInfo :: String -> Annex ()
|
||||
showInfo s = outputMessage' outputJSON (JSON.info s) $
|
||||
encodeBS (formatLongNote s)
|
||||
formatLongNote (encodeBS s)
|
||||
|
||||
showEndOk :: Annex ()
|
||||
showEndOk = showEndResult True
|
||||
|
|
@ -207,20 +208,20 @@ endResult :: Bool -> S.ByteString
|
|||
endResult True = "ok"
|
||||
endResult False = "failed"
|
||||
|
||||
toplevelWarning :: Bool -> String -> Annex ()
|
||||
toplevelWarning makeway s = warning' makeway ("git-annex: " ++ s)
|
||||
toplevelWarning :: Bool -> StringContainingQuotedPath -> Annex ()
|
||||
toplevelWarning makeway s = warning' makeway id ("git-annex: " <> s)
|
||||
|
||||
warning :: String -> Annex ()
|
||||
warning = warning' True . indent
|
||||
warning :: StringContainingQuotedPath -> Annex ()
|
||||
warning = warning' True indent
|
||||
|
||||
earlyWarning :: String -> Annex ()
|
||||
earlyWarning = warning' False
|
||||
earlyWarning :: StringContainingQuotedPath -> Annex ()
|
||||
earlyWarning = warning' False id
|
||||
|
||||
warning' :: Bool -> String -> Annex ()
|
||||
warning' makeway w = do
|
||||
warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
||||
warning' makeway consolewhitespacef w = do
|
||||
when makeway $
|
||||
outputMessage JSON.none "\n"
|
||||
outputError (w ++ "\n")
|
||||
outputError consolewhitespacef (w <> "\n")
|
||||
|
||||
{- Not concurrent output safe. -}
|
||||
warningIO :: String -> IO ()
|
||||
|
|
@ -229,8 +230,8 @@ warningIO w = do
|
|||
hFlush stdout
|
||||
hPutStrLn stderr w
|
||||
|
||||
indent :: String -> String
|
||||
indent = intercalate "\n" . map (\l -> " " ++ l) . lines
|
||||
indent :: S.ByteString -> S.ByteString
|
||||
indent = S.intercalate "\n" . map (" " <>) . S8.lines
|
||||
|
||||
{- Shows a JSON chunk only when in json mode. -}
|
||||
maybeShowJSON :: JSON.JSONChunk v -> Annex ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
|
@ -13,6 +13,8 @@ import Types.Messages
|
|||
import Messages.Concurrent
|
||||
import qualified Messages.JSON as JSON
|
||||
import Messages.JSON (JSONBuilder)
|
||||
import Git.Filename
|
||||
import Types.GitConfig
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
|
||||
|
|
@ -75,22 +77,27 @@ outputJSON jsonbuilder s = case outputType s of
|
|||
(fst <$> jsonbuilder Nothing)
|
||||
return True
|
||||
|
||||
outputError :: String -> Annex ()
|
||||
outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
|
||||
outputError :: (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
||||
outputError consolewhitespacef msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
|
||||
(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 ->
|
||||
st { Annex.output = s { jsonBuffer = jb' } }
|
||||
(SerializedOutput h _, _) ->
|
||||
liftIO $ outputSerialized h $ OutputError msg
|
||||
(SerializedOutput h _, _) -> do
|
||||
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
|
||||
where
|
||||
go = liftIO $ do
|
||||
hFlush stdout
|
||||
hPutStr stderr msg
|
||||
hFlush stderr
|
||||
go = do
|
||||
qp <- coreQuotePath <$> Annex.getGitConfig
|
||||
liftIO $ hFlush stdout
|
||||
liftIO $ S.hPutStr stderr (consolewhitespacef $ quote qp msg)
|
||||
liftIO $ hFlush stderr
|
||||
|
||||
q :: Monad m => m ()
|
||||
q = noop
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import Messages.Internal
|
|||
import Messages.Progress
|
||||
import qualified Messages.JSON as JSON
|
||||
import Utility.Metered (BytesProcessed, setMeterTotalSize)
|
||||
import Git.Filename
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
|
|
@ -54,7 +55,7 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing
|
|||
msg
|
||||
loop st
|
||||
Left (OutputError msg) -> do
|
||||
runannex $ outputError msg
|
||||
runannex $ outputError id $ UnquotedString msg
|
||||
loop st
|
||||
Left (JSONObject b) -> do
|
||||
runannex $ withMessageState $ \s -> case outputType s of
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Remote.Adb (remote) where
|
||||
|
||||
|
|
|
|||
|
|
@ -583,7 +583,7 @@ receiveMessage st external handleresponse handlerequest handleexceptional =
|
|||
Just msg -> maybe (protocolError True s) id (handleexceptional msg)
|
||||
Nothing -> protocolError False s
|
||||
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
|
||||
then "(command not allowed at this time)"
|
||||
else "(unable to parse command)"
|
||||
|
|
@ -713,7 +713,7 @@ startExternal' external = do
|
|||
] ++ exrest
|
||||
|
||||
unusable msg = do
|
||||
warning msg
|
||||
warning (UnquotedString msg)
|
||||
giveup ("unable to use external special remote " ++ basecmd)
|
||||
|
||||
stopExternal :: External -> Annex ()
|
||||
|
|
|
|||
3
Remote/External/AsyncExtension.hs
vendored
3
Remote/External/AsyncExtension.hs
vendored
|
|
@ -7,6 +7,7 @@
|
|||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Remote.External.AsyncExtension (runRelayToExternalAsync) where
|
||||
|
||||
|
|
@ -86,7 +87,7 @@ receiveloop external st jidmap sendq sendthread annexrunner = externalReceive st
|
|||
Nothing -> closeandshutdown
|
||||
where
|
||||
protoerr s = do
|
||||
annexrunner $ warning $ "async external special remote protocol error: " ++ s
|
||||
annexrunner $ warning $ "async external special remote protocol error: " <> s
|
||||
closeandshutdown
|
||||
|
||||
closeandshutdown = do
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ gen baser u rc gc rs = do
|
|||
setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
|
||||
gen' r u' pc gc rs
|
||||
_ -> 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
|
||||
|
||||
gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
|
|
|
|||
|
|
@ -275,12 +275,12 @@ tryGitConfigRead autoinit r hasuuid
|
|||
case v of
|
||||
Right (r', val, _err) -> do
|
||||
unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do
|
||||
warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
||||
warning $ "Instead, got: " ++ show val
|
||||
warning $ "This is unexpected; please check the network transport!"
|
||||
warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
|
||||
warning $ UnquotedString $ "Instead, got: " ++ show val
|
||||
warning "This is unexpected; please check the network transport!"
|
||||
return $ Right r'
|
||||
Left l -> do
|
||||
warning $ "Unable to parse git config from " ++ configloc
|
||||
warning $ UnquotedString $ "Unable to parse git config from " ++ configloc
|
||||
return $ Left (show l)
|
||||
|
||||
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
|
||||
|
|
@ -306,7 +306,7 @@ tryGitConfigRead autoinit r hasuuid
|
|||
return r'
|
||||
Left err -> do
|
||||
set_ignore "not usable by git-annex" False
|
||||
warning $ url ++ " " ++ err
|
||||
warning $ UnquotedString $ url ++ " " ++ err
|
||||
return r
|
||||
|
||||
{- Is this remote just not available, or does
|
||||
|
|
@ -323,9 +323,9 @@ tryGitConfigRead autoinit r hasuuid
|
|||
case Git.remoteName r of
|
||||
Nothing -> noop
|
||||
Just n -> do
|
||||
warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"
|
||||
warning $ UnquotedString $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"
|
||||
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 setter v = case Git.remoteName r of
|
||||
|
|
@ -348,7 +348,7 @@ tryGitConfigRead autoinit r hasuuid
|
|||
let check = do
|
||||
Annex.BranchState.disableUpdate
|
||||
catchNonAsync (autoInitialize (pure [])) $ \e ->
|
||||
warning $ "Remote " ++ Git.repoDescribe r ++
|
||||
warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++
|
||||
": " ++ show e
|
||||
Annex.getState Annex.repo
|
||||
s <- newLocal r
|
||||
|
|
@ -359,7 +359,7 @@ tryGitConfigRead autoinit r hasuuid
|
|||
unless hasuuid $ case Git.remoteName r of
|
||||
Nothing -> noop
|
||||
Just n -> do
|
||||
warning $ "Remote " ++ n ++ " cannot currently be accessed."
|
||||
warning $ UnquotedString $ "Remote " ++ n ++ " cannot currently be accessed."
|
||||
return r
|
||||
|
||||
configlistfields = if autoinit
|
||||
|
|
@ -770,7 +770,7 @@ mkState r u gc = do
|
|||
let ok = u' == u
|
||||
void $ liftIO $ tryPutMVar cv 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
|
||||
, liftIO $ readMVar cv
|
||||
)
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@ discoverLFSEndpoint tro h
|
|||
warning "Unable to parse ssh url for git-lfs remote."
|
||||
return Nothing
|
||||
Just (Left err) -> do
|
||||
warning err
|
||||
warning (UnquotedString err)
|
||||
return Nothing
|
||||
Just (Right hostuser) -> do
|
||||
let port = Git.Url.port r
|
||||
|
|
@ -275,11 +275,11 @@ discoverLFSEndpoint tro h
|
|||
(sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd
|
||||
liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case
|
||||
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
|
||||
Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of
|
||||
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
|
||||
Just endpoint -> return (Just endpoint)
|
||||
|
||||
|
|
|
|||
|
|
@ -100,7 +100,7 @@ storeChunked annexrunner chunksize dests storer content =
|
|||
| otherwise = storechunks sz [] dests content
|
||||
|
||||
onerr e = do
|
||||
annexrunner $ warning (show e)
|
||||
annexrunner $ warning (UnquotedString (show e))
|
||||
return []
|
||||
|
||||
storechunks _ _ [] _ = return [] -- ran out of dests
|
||||
|
|
|
|||
|
|
@ -298,7 +298,7 @@ runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do
|
|||
-- When runFullProto fails, the connection is no longer
|
||||
-- usable, so close it.
|
||||
Left e -> do
|
||||
warning $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"
|
||||
warning $ UnquotedString $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"
|
||||
conn' <- fst <$> liftIO (closeP2PSshConnection conn)
|
||||
return (conn', Nothing)
|
||||
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ lookupHook hookname action = do
|
|||
fallback <- fromConfigValue <$> getConfig hookfallback mempty
|
||||
if null fallback
|
||||
then do
|
||||
warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback
|
||||
warning $ UnquotedString $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback
|
||||
return Nothing
|
||||
else return $ Just fallback
|
||||
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))
|
||||
( a
|
||||
, do
|
||||
warning $ hook ++ " hook exited nonzero!"
|
||||
warning $ UnquotedString $ hook ++ " hook exited nonzero!"
|
||||
return False
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Remote.P2P (
|
||||
remote,
|
||||
chainGen
|
||||
|
|
@ -105,7 +107,7 @@ runProtoConn a c@(OpenConnection (runst, conn)) = do
|
|||
-- so close it.
|
||||
case v of
|
||||
Left e -> do
|
||||
warning $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")"
|
||||
warning $ UnquotedString $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")"
|
||||
liftIO $ closeConnection conn
|
||||
return (ClosedConnection, Nothing)
|
||||
Right r -> return (c, Just r)
|
||||
|
|
@ -163,9 +165,9 @@ openConnection u addr = do
|
|||
liftIO $ closeConnection conn
|
||||
return ClosedConnection
|
||||
Left e -> do
|
||||
warning $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")"
|
||||
warning $ UnquotedString $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")"
|
||||
liftIO $ closeConnection conn
|
||||
return ClosedConnection
|
||||
Left e -> do
|
||||
warning $ "Unable to connect to peer. (" ++ show e ++ ")"
|
||||
warning $ UnquotedString $ "Unable to connect to peer. (" ++ show e ++ ")"
|
||||
return ClosedConnection
|
||||
|
|
|
|||
10
Remote/S3.hs
10
Remote/S3.hs
|
|
@ -423,13 +423,13 @@ retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case
|
|||
Right h ->
|
||||
eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
|
||||
Left failreason -> do
|
||||
warning failreason
|
||||
warning (UnquotedString failreason)
|
||||
giveup "cannot download content"
|
||||
Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv
|
||||
Left S3HandleNeedCreds ->
|
||||
getPublicWebUrls' (uuid r) rs info c k >>= \case
|
||||
Left failreason -> do
|
||||
warning failreason
|
||||
warning (UnquotedString failreason)
|
||||
giveup "cannot download content"
|
||||
Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $
|
||||
giveup "failed to download content"
|
||||
|
|
@ -470,13 +470,13 @@ checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig ->
|
|||
checkKey hv r rs c info k = withS3Handle hv $ \case
|
||||
Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
|
||||
Left failreason -> do
|
||||
warning failreason
|
||||
warning (UnquotedString failreason)
|
||||
giveup "cannot check content"
|
||||
Right loc -> checkKeyHelper info h loc
|
||||
Left S3HandleNeedCreds ->
|
||||
getPublicWebUrls' (uuid r) rs info c k >>= \case
|
||||
Left failreason -> do
|
||||
warning failreason
|
||||
warning (UnquotedString failreason)
|
||||
giveup "cannot check content"
|
||||
Right us -> do
|
||||
let check u = withUrlOptions $
|
||||
|
|
@ -865,7 +865,7 @@ data S3HandleProblem
|
|||
|
||||
giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a
|
||||
giveupS3HandleProblem S3HandleNeedCreds u = do
|
||||
warning $ needS3Creds u
|
||||
warning $ UnquotedString $ needS3Creds u
|
||||
giveup "No S3 credentials configured"
|
||||
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."
|
||||
|
|
|
|||
|
|
@ -211,7 +211,7 @@ lookupKey1 file = do
|
|||
Nothing -> do
|
||||
unless (null kname || null bname ||
|
||||
not (isLinkToAnnex (toRawFilePath l))) $
|
||||
warning skip
|
||||
warning (UnquotedString skip)
|
||||
return Nothing
|
||||
Just backend -> return $ Just (k, backend)
|
||||
where
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ upgrade automatic = flip catchNonAsync onexception $ do
|
|||
return UpgradeSuccess
|
||||
where
|
||||
onexception e = do
|
||||
warning $ "caught exception: " ++ show e
|
||||
warning $ UnquotedString $ "caught exception: " ++ show e
|
||||
return UpgradeFailed
|
||||
|
||||
-- git before 2.22 would OOM running git status on a large file.
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ upgrade automatic
|
|||
)
|
||||
| otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getRead Annex.force))
|
||||
( do
|
||||
warning $ unlines unsafeupgrade
|
||||
warning $ UnquotedString $ unlines unsafeupgrade
|
||||
return UpgradeDeferred
|
||||
, performUpgrade automatic
|
||||
)
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ behave more like git.
|
|||
> Update: Most git-annex commands now quote filenames, due to work on
|
||||
> ActionItem display. `git-annex find`, `git-annex info $file`,
|
||||
> and everywhere filenames get
|
||||
> embedded in warnings, info messages, still need to be done.
|
||||
> embedded in info messages still need to be done.
|
||||
|
||||
----
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue