From 3290a09a70ef907dec89d38728f22f9916a614f3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Apr 2023 14:47:32 -0400 Subject: [PATCH] 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 --- Annex/Action.hs | 4 +- Annex/AdjustedBranch.hs | 9 ++- Annex/BloomFilter.hs | 3 +- Annex/Common.hs | 1 + Annex/Content.hs | 10 ++- Annex/Content/LowLevel.hs | 3 +- Annex/Difference.hs | 2 + Annex/Export.hs | 3 +- Annex/Hook.hs | 5 +- Annex/Import.hs | 10 +-- Annex/Ingest.hs | 20 +++-- Annex/Init.hs | 4 +- Annex/Link.hs | 21 +++-- Annex/LockPool/PosixOrPid.hs | 3 +- Annex/MetaData.hs | 2 +- Annex/SpecialRemote.hs | 2 +- Annex/Ssh.hs | 4 +- Annex/Transfer.hs | 6 +- Annex/Url.hs | 8 +- Annex/Verify.hs | 3 +- Annex/YoutubeDl.hs | 2 +- Assistant/Threads/Committer.hs | 6 +- Assistant/Threads/MountWatcher.hs | 2 +- Assistant/Threads/NetWatcher.hs | 2 +- Assistant/Threads/PairListener.hs | 4 +- Assistant/Threads/SanityChecker.hs | 4 +- Assistant/Threads/Watcher.hs | 4 +- Backend.hs | 5 +- Backend/External.hs | 5 +- Backend/Hash.hs | 2 +- CmdLine/Action.hs | 2 +- CmdLine/GitAnnex/Options.hs | 2 +- CmdLine/Seek.hs | 8 +- Command/Add.hs | 3 +- Command/AddUrl.hs | 21 +++-- Command/DropUnused.hs | 2 + Command/EnableTor.hs | 2 +- Command/Export.hs | 2 +- Command/FromKey.hs | 4 +- Command/Fsck.hs | 87 ++++++++++----------- Command/Import.hs | 11 ++- Command/ImportFeed.hs | 8 +- Command/Multicast.hs | 4 +- Command/P2P.hs | 2 +- Command/ReKey.hs | 3 +- Command/Reinject.hs | 1 - Command/Smudge.hs | 6 +- Command/Sync.hs | 6 +- Command/TestRemote.hs | 1 - Command/TransferKey.hs | 4 +- Command/TransferKeys.hs | 4 +- Command/Transferrer.hs | 4 +- Command/Trust.hs | 2 +- Command/Undo.hs | 1 - Command/View.hs | 2 + Command/Whereis.hs | 2 +- Creds.hs | 2 +- Messages.hs | 31 ++++---- Messages/Internal.hs | 29 ++++--- Messages/Serialized.hs | 3 +- Remote/Adb.hs | 1 + Remote/External.hs | 4 +- Remote/External/AsyncExtension.hs | 3 +- Remote/GCrypt.hs | 2 +- Remote/Git.hs | 20 ++--- Remote/GitLFS.hs | 6 +- Remote/Helper/Chunked/Legacy.hs | 2 +- Remote/Helper/Ssh.hs | 2 +- Remote/Hook.hs | 4 +- Remote/P2P.hs | 8 +- Remote/S3.hs | 10 +-- Upgrade/V1.hs | 2 +- Upgrade/V5.hs | 2 +- Upgrade/V9.hs | 2 +- doc/todo/terminal_escapes_in_filenames.mdwn | 2 +- 75 files changed, 259 insertions(+), 229 deletions(-) diff --git a/Annex/Action.hs b/Annex/Action.hs index 641a184e62..9eaf169851 100644 --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -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) diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index 66d633d699..2a3d9356a6 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -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 diff --git a/Annex/BloomFilter.hs b/Annex/BloomFilter.hs index 544fdeeccc..571f1c6c17 100644 --- a/Annex/BloomFilter.hs +++ b/Annex/BloomFilter.hs @@ -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 diff --git a/Annex/Common.hs b/Annex/Common.hs index 2edc0788b4..fc0a25b1d0 100644 --- a/Annex/Common.hs +++ b/Annex/Common.hs @@ -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 diff --git a/Annex/Content.hs b/Annex/Content.hs index f1b147fddb..3d014b2534 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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. diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs index 947acabb1b..ec8284bedb 100644 --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -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 ) diff --git a/Annex/Difference.hs b/Annex/Difference.hs index 4d13c7211c..fa874476fd 100644 --- a/Annex/Difference.hs +++ b/Annex/Difference.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Difference ( module Types.Difference, setDifferences, diff --git a/Annex/Export.hs b/Annex/Export.hs index 3ab68ad530..489d8984e0 100644 --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -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 diff --git a/Annex/Hook.hs b/Annex/Hook.hs index 467c1f07da..8c6d648fb0 100644 --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -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" diff --git a/Annex/Import.hs b/Annex/Import.hs index 68c8aa8281..a3f6c4a56d 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -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 $ diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index baeb5fae9c..26a5e388eb 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -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 diff --git a/Annex/Init.hs b/Annex/Init.hs index 860206c604..a82deffd15 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -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' diff --git a/Annex/Link.hs b/Annex/Link.hs index 4ef0a12689..dfb18a3d57 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -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. - diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs index 91e34c25ec..c7d7596ed8 100644 --- a/Annex/LockPool/PosixOrPid.hs +++ b/Annex/LockPool/PosixOrPid.hs @@ -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 diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs index fdc539a324..1eba836455 100644 --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -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 diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs index d2dc146af9..d863f26055 100644 --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -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) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 17124cdfb2..0c340496f7 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -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" diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 22801a9619..2ecf096b68 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -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 diff --git a/Annex/Url.hs b/Annex/Url.hs index 584482cdc8..49a90e7221 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -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) diff --git a/Annex/Verify.hs b/Annex/Verify.hs index 5703bf41e4..3b95bac30f 100644 --- a/Annex/Verify.hs +++ b/Annex/Verify.hs @@ -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" diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 1dd0d56ec8..1fe30b5307 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -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) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index b75111a382..d11efda3e2 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -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 diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 7a59018bcb..11997fbd71 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -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 diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 7d4b6cc138..f86872d74c 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -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) diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 8a5ba7914c..0199b79f84 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -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 diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 87587e227f..563e038e78 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -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 diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 540ac5c6c5..60b143d224 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -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 diff --git a/Backend.hs b/Backend.hs index ba5c6f3650..a1ea0184ad 100644 --- a/Backend.hs +++ b/Backend.hs @@ -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 diff --git a/Backend/External.hs b/Backend/External.hs index 4e161cb17e..b0cdd0cefd 100644 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -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 diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 78ece71292..86f9ea661a 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -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 diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index d99cdad17a..412cab8f4a 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -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 diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 9e6cd50c39..d5364a0a60 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index b3bb8c3a86..d2815383a5 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 diff --git a/Command/Add.hs b/Command/Add.hs index a9ea7e42b1..e1e2c32e79 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index a76c54a200..5997fba5f0 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -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 ) diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 4d2e868e7d..33a54279ea 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.DropUnused where import Command diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs index df518c2fa0..71a99f9865 100644 --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -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 diff --git a/Command/Export.hs b/Command/Export.hs index 9df30125a8..3739bc95e3 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -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 diff --git a/Command/FromKey.hs b/Command/FromKey.hs index ff8d72d63b..6d3cc4da60 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 879d9029d7..3992503d55 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/Import.hs b/Command/Import.hs index b797c2487a..193a066deb 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -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 diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index fcddae4a4d..2b6803024f 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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 ) diff --git a/Command/Multicast.hs b/Command/Multicast.hs index d1e6260715..faa0a09aa1 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -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 $ diff --git a/Command/P2P.hs b/Command/P2P.hs index e26e90d860..16155168ed 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -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 diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 906d4b5dff..72e852fd11 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -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 diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 363c44b20c..13109ac005 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -18,7 +18,6 @@ import Utility.Metered import Annex.WorkTree import qualified Git import qualified Annex -import Git.Filename cmd :: Command cmd = withAnnexOptions [backendOption] $ diff --git a/Command/Smudge.hs b/Command/Smudge.hs index ae0b46a33a..5ca290c113 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index 96e7237df9..2f5d17ec71 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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))) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 32f48ab5be..cd7f2a522f 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 6b38a0bc53..78820c0db5 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -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 diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 078f905eee..3d28a23894 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -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 diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs index d3cf624a34..83b364fb85 100644 --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -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 diff --git a/Command/Trust.hs b/Command/Trust.hs index 993ec89b77..17c21b54ba 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -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 diff --git a/Command/Undo.hs b/Command/Undo.hs index c56606c20d..cae7750fab 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -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 diff --git a/Command/View.hs b/Command/View.hs index 60ec890537..349688eb96 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.View where import Command diff --git a/Command/Whereis.hs b/Command/Whereis.hs index c6ddc88072..1345ef7eb7 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -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:" diff --git a/Creds.hs b/Creds.hs index 95124f160d..1ec927bf94 100644 --- a/Creds.hs +++ b/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 diff --git a/Messages.hs b/Messages.hs index 36b7cbb444..45b7de6209 100644 --- a/Messages.hs +++ b/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 () diff --git a/Messages/Internal.hs b/Messages/Internal.hs index e88acf041c..d3c984e988 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2023 Joey Hess - - 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 diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs index 3f20d1a27d..9a1cceda0f 100644 --- a/Messages/Serialized.hs +++ b/Messages/Serialized.hs @@ -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 diff --git a/Remote/Adb.hs b/Remote/Adb.hs index d4144f1988..f70fe27bdf 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.Adb (remote) where diff --git a/Remote/External.hs b/Remote/External.hs index 352b9eb68d..6c9cb4a979 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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 () diff --git a/Remote/External/AsyncExtension.hs b/Remote/External/AsyncExtension.hs index 177249c1cb..34b04297a0 100644 --- a/Remote/External/AsyncExtension.hs +++ b/Remote/External/AsyncExtension.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 1ab9461e6f..3429c1a037 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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) diff --git a/Remote/Git.hs b/Remote/Git.hs index 37b4df4360..ef0226f6f7 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 ) diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 6e2607e321..fc3459f46f 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -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) diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs index b3454ab2dc..faae6ddc90 100644 --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -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 diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 9bd4990650..05aa53452e 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -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) diff --git a/Remote/Hook.hs b/Remote/Hook.hs index b27bcaa341..49d72a8a6c 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 ) diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 959ecbbf58..a5fd926a36 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 861b5d20d3..a2b09165a1 100644 --- a/Remote/S3.hs +++ b/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." diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 4f6dfca226..b0a4304d49 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -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 diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index f3b1de01cb..d580befe05 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -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. diff --git a/Upgrade/V9.hs b/Upgrade/V9.hs index 21c73fe5fb..bb45228caf 100644 --- a/Upgrade/V9.hs +++ b/Upgrade/V9.hs @@ -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 ) diff --git a/doc/todo/terminal_escapes_in_filenames.mdwn b/doc/todo/terminal_escapes_in_filenames.mdwn index 575bcbfd78..e59bd7fde8 100644 --- a/doc/todo/terminal_escapes_in_filenames.mdwn +++ b/doc/todo/terminal_escapes_in_filenames.mdwn @@ -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. ---- -- 2.30.2