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