filter out control characters in error messages

giveup changed to filter out control characters. (It is too low level to
make it use StringContainingQuotedPath.)

error still does not, but it should only be used for internal errors,
where the message is not attacker-controlled.

Changed a lot of existing error to giveup when it is not strictly an
internal error.

Of course, other exceptions can still be thrown, either by code in
git-annex, or a library, that include some attacker-controlled value.
This does not guard against those.

Sponsored-by: Noam Kremen on Patreon

Annex/Branch.hs

@@ -130,7 +130,7 @@ getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha
 			, Param $ fromRef name
 			, Param $ fromRef originname
 			]
-		fromMaybe (error $ "failed to create " ++ fromRef name)
+		fromMaybe (giveup $ "failed to create " ++ fromRef name)
 			<$> branchsha
 	go False = withIndex' True $ do
 		-- Create the index file. This is not necessary,

Annex/GitOverlay.hs

@@ -73,7 +73,7 @@ withWorkTree d a = withAltRepo
 	(const a)
   where
 	modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }
-	modlocation _ = error "withWorkTree of non-local git repo"
+	modlocation _ = giveup "withWorkTree of non-local git repo"
 
 {- Runs an action with the git index file and HEAD, and a few other
  - files that are related to the work tree coming from an overlay

Annex/Import.hs

@@ -458,10 +458,10 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 	gochunked db c
 		-- Downloading cannot be done when chunked, since only
 		-- the first chunk is processed before returning.
-		| importcontent = error "importKeys does not support downloading chunked import"
+		| importcontent = giveup "importKeys does not support downloading chunked import"
 		-- Chunked import is currently only used by thirdpartypopulated
 		-- remotes.
-		| not thirdpartypopulated = error "importKeys does not support chunked import when not thirdpartypopulated"
+		| not thirdpartypopulated = giveup "importKeys does not support chunked import when not thirdpartypopulated"
 		| otherwise = do
 			l <- forM (importableContentsSubTree c) $ \(loc, i) -> do
 				let loc' = importableContentsChunkFullLocation (importableContentsSubDir c) loc

Annex/Ssh.hs

@@ -432,7 +432,7 @@ sshOptionsTo remote gc localr
 			( unchanged
 			, do
 				let port = Git.Url.port remote
-				let sshhost = either error id (mkSshHost host)
+				let sshhost = either giveup id (mkSshHost host)
 				(msockfile, cacheparams) <- sshCachingInfo (sshhost, port)
 				case msockfile of
 					Nothing -> use []

Assistant/DeleteRemote.hs

@@ -31,7 +31,7 @@ import qualified Data.Text as T
  - Remote data. -}
 disableRemote :: UUID -> Assistant Remote
 disableRemote uuid = do
-	remote <- fromMaybe (error "unknown remote")
+	remote <- fromMaybe (giveup "unknown remote")
 		<$> liftAnnex (Remote.remoteFromUUID uuid)
 	liftAnnex $ do
 		inRepo $ Git.Remote.Remove.remove (Remote.name remote)
@@ -57,7 +57,7 @@ removableRemote urlrenderer uuid = getkeys >>= \case
 	Just keys
 		| null keys -> finishRemovingRemote urlrenderer uuid
 		| otherwise -> do
-			r <- fromMaybe (error "unknown remote")
+			r <- fromMaybe (giveup "unknown remote")
 				<$> liftAnnex (Remote.remoteFromUUID uuid)
 			mapM_ (queueremaining r) keys
 	Nothing -> noop

Assistant/MakeRemote.hs

@@ -47,7 +47,7 @@ addRemote :: Annex RemoteName -> Annex Remote
 addRemote a = do
 	name <- a
 	remotesChanged
-	maybe (error "failed to add remote") return
+	maybe (giveup "failed to add remote") return
 		=<< Remote.byName (Just name)
 
 {- Inits a rsync special remote, and returns its name. -}
@@ -94,7 +94,7 @@ initSpecialRemote name remotetype mcreds config = go 0
 enableSpecialRemote :: SpecialRemoteMaker
 enableSpecialRemote name remotetype mcreds config =
 	Annex.SpecialRemote.findExisting name >>= \case
-		[] -> error $ "Cannot find a special remote named " ++ name
+		[] -> giveup $ "Cannot find a special remote named " ++ name
 		((u, c, mcu):_) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu
 
 setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName

Assistant/MakeRepo.hs

@@ -34,7 +34,7 @@ makeRepo path bare = ifM (probeRepoExists path)
 		(transcript, ok) <-
 			processTranscript "git" (toCommand params) Nothing
 		unless ok $
-			error $ "git init failed!\nOutput:\n" ++ transcript
+			giveup $ "git init failed!\nOutput:\n" ++ transcript
 		return True
 	)
   where

Assistant/Pairing/MakeRemote.hs

@@ -24,11 +24,11 @@ import qualified Data.Text as T
  - side can immediately begin syncing. -}
 setupAuthorizedKeys :: PairMsg -> FilePath -> IO ()
 setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
-	Left err -> error err
+	Left err -> giveup err
 	Right pubkey -> do
 		absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir)
 		unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $
-			error "failed setting up ssh authorized keys"
+			giveup "failed setting up ssh authorized keys"
 
 {- When local pairing is complete, this is used to set up the remote for
  - the host we paired with. -}

Assistant/Ssh.hs

@@ -68,7 +68,7 @@ sshOpt k v = concat ["-o", k, "=", v]
 
 {- user@host or host -}
 genSshHost :: Text -> Maybe Text -> SshHost
-genSshHost host user = either error id $ mkSshHost $
+genSshHost host user = either giveup id $ mkSshHost $
 	maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
 
 {- Generates a ssh or rsync url from a SshData. -}
@@ -218,7 +218,7 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
 		, Param "-f", File $ dir </> "key"
 		]
 	unless ok $
-		error "ssh-keygen failed"
+		giveup "ssh-keygen failed"
 	SshKeyPair
 		<$> readFile (dir </> "key.pub")
 		<*> readFile (dir </> "key")

Assistant/Threads/Merger.hs

@@ -58,7 +58,7 @@ runHandler handler file _filestatus =
 
 {- Called when there's an error with inotify. -}
 onErr :: Handler
-onErr = error
+onErr = giveup
 
 {- Called when a new branch ref is written, or a branch ref is modified.
  -

Assistant/Threads/TransferWatcher.hs

@@ -53,7 +53,7 @@ runHandler handler file _filestatus =
 
 {- Called when there's an error with inotify. -}
 onErr :: Handler
-onErr = error
+onErr = giveup
 
 {- Called when a new transfer information file is written. -}
 onAdd :: Handler

Assistant/Upgrade.hs

@@ -205,7 +205,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
 				, Param "--directory", File tmpdir
 				]
 			unless tarok $
-				error $ "failed to untar " ++ distributionfile
+				giveup $ "failed to untar " ++ distributionfile
 			sanitycheck $ tmpdir </> installBase
 			installby R.rename newdir (tmpdir </> installBase)
 		let deleteold = do
@@ -218,7 +218,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
 #endif
 	sanitycheck dir = 
 		unlessM (doesDirectoryExist dir) $
-			error $ "did not find " ++ dir ++ " in " ++ distributionfile
+			giveup $ "did not find " ++ dir ++ " in " ++ distributionfile
 	makeorigsymlink olddir = do
 		let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase
 		removeWhenExistsWith R.removeLink (toRawFilePath origdir)
@@ -227,7 +227,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
 {- Finds where the old version was installed. -}
 oldVersionLocation :: IO FilePath
 oldVersionLocation = readProgramFile >>= \case
-	Nothing -> error "Cannot find old distribution bundle; not upgrading."
+	Nothing -> giveup "Cannot find old distribution bundle; not upgrading."
 	Just pf -> do
 		let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf
 #ifdef darwin_HOST_OS
@@ -240,7 +240,7 @@ oldVersionLocation = readProgramFile >>= \case
 		let olddir = pdir
 #endif
 		when (null olddir) $
-			error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
+			giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"
 		return olddir
 
 {- Finds a place to install the new version.

Assistant/WebApp/Configurators/Delete.hs

@@ -34,7 +34,7 @@ notCurrentRepo uuid a = do
 		then redirect DeleteCurrentRepositoryR
 		else go =<< liftAnnex (Remote.remoteFromUUID uuid)
   where
-	go Nothing = error "Unknown UUID"
+	go Nothing = giveup "Unknown UUID"
 	go (Just _) = a
 
 getDeleteRepositoryR :: UUID -> Handler Html
@@ -45,7 +45,7 @@ getDeleteRepositoryR uuid = notCurrentRepo uuid $ do
 
 getStartDeleteRepositoryR :: UUID -> Handler Html
 getStartDeleteRepositoryR uuid = do
-	remote <- fromMaybe (error "unknown remote")
+	remote <- fromMaybe (giveup "unknown remote")
 		<$> liftAnnex (Remote.remoteFromUUID uuid)
 	liftAnnex $ do
 		trustSet uuid UnTrusted

Assistant/WebApp/Configurators/Edit.hs

@@ -203,7 +203,7 @@ editForm new (RepoUUID uuid)
 		mremote <- liftAnnex $ Remote.remoteFromUUID uuid
 		when (mremote == Nothing) $
 			whenM ((/=) uuid <$> liftAnnex getUUID) $
-				error "unknown remote"
+				giveup "unknown remote"
 		curr <- liftAnnex $ getRepoConfig uuid mremote
 		liftAnnex $ checkAssociatedDirectory curr mremote
 		mrepo <- liftAnnex $

Assistant/WebApp/Configurators/Pairing.hs

@@ -216,10 +216,10 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
 	 - background. -}
 	thread <- liftAssistant $ asIO $ do
 		keypair <- liftIO $ genSshKeyPair
-		let pubkey = either error id $ validateSshPubKey $ sshPubKey keypair
+		let pubkey = either giveup id $ validateSshPubKey $ sshPubKey keypair
 		pairdata <- liftIO $ PairData
 			<$> getHostname
-			<*> (either error id <$> myUserName)
+			<*> (either giveup id <$> myUserName)
 			<*> pure reldir
 			<*> pure pubkey
 			<*> (maybe genUUID return muuid)

Assistant/WebApp/Page.hs

@@ -67,7 +67,7 @@ customPage' with_longpolling navbaritem content = do
 					addScript $ StaticR js_longpolling_js
 				$(widgetFile "page")
 			withUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
-		Just msg -> error msg
+		Just msg -> giveup msg
   where
 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
 

Backend/Hash.hs

@@ -229,7 +229,7 @@ sha2Hasher (HashSize hashsize)
 	| hashsize == 224 = mkHasher sha2_224 sha2_224_context
 	| hashsize == 384 = mkHasher sha2_384 sha2_384_context
 	| hashsize == 512 = mkHasher sha2_512 sha2_512_context
-	| otherwise = error $ "unsupported SHA2 size " ++ show hashsize
+	| otherwise = giveup $ "unsupported SHA2 size " ++ show hashsize
 
 sha3Hasher :: HashSize -> Hasher
 sha3Hasher (HashSize hashsize)
@@ -237,13 +237,13 @@ sha3Hasher (HashSize hashsize)
 	| hashsize == 224 = mkHasher sha3_224 sha3_224_context
 	| hashsize == 384 = mkHasher sha3_384 sha3_384_context
 	| hashsize == 512 = mkHasher sha3_512 sha3_512_context
-	| otherwise = error $ "unsupported SHA3 size " ++ show hashsize
+	| otherwise = giveup $ "unsupported SHA3 size " ++ show hashsize
 
 skeinHasher :: HashSize -> Hasher
 skeinHasher (HashSize hashsize)
 	| hashsize == 256 = mkHasher skein256 skein256_context
 	| hashsize == 512 = mkHasher skein512 skein512_context
-	| otherwise = error $ "unsupported SKEIN size " ++ show hashsize
+	| otherwise = giveup $ "unsupported SKEIN size " ++ show hashsize
 
 blake2bHasher :: HashSize -> Hasher
 blake2bHasher (HashSize hashsize)
@@ -252,25 +252,25 @@ blake2bHasher (HashSize hashsize)
 	| hashsize == 160 = mkHasher blake2b_160 blake2b_160_context
 	| hashsize == 224 = mkHasher blake2b_224 blake2b_224_context
 	| hashsize == 384 = mkHasher blake2b_384 blake2b_384_context
-	| otherwise = error $ "unsupported BLAKE2B size " ++ show hashsize
+	| otherwise = giveup $ "unsupported BLAKE2B size " ++ show hashsize
 
 blake2bpHasher :: HashSize -> Hasher
 blake2bpHasher (HashSize hashsize)
 	| hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_context
-	| otherwise = error $ "unsupported BLAKE2BP size " ++ show hashsize
+	| otherwise = giveup $ "unsupported BLAKE2BP size " ++ show hashsize
 
 blake2sHasher :: HashSize -> Hasher
 blake2sHasher (HashSize hashsize)
 	| hashsize == 256 = mkHasher blake2s_256 blake2s_256_context
 	| hashsize == 160 = mkHasher blake2s_160 blake2s_160_context
 	| hashsize == 224 = mkHasher blake2s_224 blake2s_224_context
-	| otherwise = error $ "unsupported BLAKE2S size " ++ show hashsize
+	| otherwise = giveup $ "unsupported BLAKE2S size " ++ show hashsize
 
 blake2spHasher :: HashSize -> Hasher
 blake2spHasher (HashSize hashsize)
 	| hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_context
 	| hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_context
-	| otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize
+	| otherwise = giveup $ "unsupported BLAKE2SP size " ++ show hashsize
 
 sha1Hasher :: Hasher
 sha1Hasher = mkHasher sha1 sha1_context

CmdLine/GitRemoteTorAnnex.hs

@@ -25,7 +25,7 @@ run (_remotename:address:[]) = forever $
 		"capabilities" -> putStrLn "connect" >> ready
 		"connect git-upload-pack" -> go UploadPack
 		"connect git-receive-pack" -> go ReceivePack
-		l -> error $ "git-remote-helpers protocol error at " ++ show l
+		l -> giveup $ "git-remote-helpers protocol error at " ++ show l
   where
 	(onionaddress, onionport)
 		| '/' `elem` address = parseAddressPort $

CmdLine/Seek.hs

@@ -313,7 +313,7 @@ withKeyOptions' ko auto mkkeyaction fallbackaction worktreeitems = do
 					in keyaction lt (SeekInput [], k, bfp)
 				Nothing -> noop
 			unlessM (liftIO cleanup) $
-				error ("git ls-tree " ++ Git.fromRef b ++ " failed")
+				giveup ("git ls-tree " ++ Git.fromRef b ++ " failed")
 	
 	runfailedtransfers = do
 		keyaction <- mkkeyaction

Command/AddUrl.hs

@@ -148,7 +148,7 @@ checkUrl addunlockedmatcher r o si u = do
 	pathmax <- liftIO $ fileNameLengthLimit "."
 	let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o))
 	go deffile =<< maybe
-		(error $ "unable to checkUrl of " ++ Remote.name r)
+		(giveup $ "unable to checkUrl of " ++ Remote.name r)
 		(tryNonAsync . flip id u)
 		(Remote.checkUrl r)
   where

Command/Fix.hs

@@ -76,7 +76,7 @@ breakHardLink file key obj = do
 		let tmp' = toRawFilePath tmp
 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
 		unlessM (checkedCopyFile key obj tmp' mode) $
-			error "unable to break hard link"
+			giveup "unable to break hard link"
 		thawContent tmp'
 		Database.Keys.storeInodeCaches key [tmp']
 		modifyContentDir obj $ freezeContent obj
@@ -87,7 +87,7 @@ makeHardLink file key = do
 	replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
 		linkFromAnnex' key (toRawFilePath tmp) mode >>= \case
-			LinkAnnexFailed -> error "unable to make hard link"
+			LinkAnnexFailed -> giveup "unable to make hard link"
 			_ -> noop
 	next $ return True
 

Command/ImportFeed.hs

@@ -232,7 +232,7 @@ performDownload' started addunlockedmatcher opts cache todownload = case locatio
 								return (Just [])
 				else do
 					res <- tryNonAsync $ maybe
-						(error $ "unable to checkUrl of " ++ Remote.name r)
+						(giveup $ "unable to checkUrl of " ++ Remote.name r)
 						(flip id url)
 						(Remote.checkUrl r)
 					case res of

Command/Log.hs

@@ -281,7 +281,7 @@ parseRawChangeLine = go . words
 	go _ = Nothing
 
 parseTimeStamp :: String -> POSIXTime
-parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .
+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (giveup "bad timestamp") .
 	parseTimeM True defaultTimeLocale "%s"
 
 showTimeStamp :: TimeZone -> POSIXTime -> String

Command/ReKey.hs

@@ -113,7 +113,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
 				replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
 					let tmp' = toRawFilePath tmp
 					unlessM (checkedCopyFile oldkey oldobj tmp' Nothing) $
-						error "can't lock old key"
+						giveup "can't lock old key"
 					thawContent tmp'
 		ic <- withTSDelta (liftIO . genInodeCache file)
 		case v of

Command/Reinject.hs

@@ -103,7 +103,7 @@ notAnnexed src a =
 perform :: RawFilePath -> Key -> CommandPerform
 perform src key = ifM move
 	( next $ cleanup key
-	, error "failed"
+	, giveup "failed"
 	)
   where
 	move = checkDiskSpaceToGet key False $

Command/RemoteDaemon.hs

@@ -24,7 +24,7 @@ cmd = noCommit $
 
 run :: DaemonOptions -> CommandSeek
 run o
-	| stopDaemonOption o = error "--stop not implemented for remotedaemon"
+	| stopDaemonOption o = giveup "--stop not implemented for remotedaemon"
 	| foregroundDaemonOption o = liftIO runInteractive
 	| otherwise = do
 #ifndef mingw32_HOST_OS

Command/ResolveMerge.hs

@@ -28,7 +28,7 @@ start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
 	us <- fromMaybe nobranch <$> inRepo Git.Branch.current
 	d <- fromRawFilePath <$> fromRepo Git.localGitDir
 	let merge_head = d </> "MERGE_HEAD"
-	them <- fromMaybe (error nomergehead) . extractSha
+	them <- fromMaybe (giveup nomergehead) . extractSha
 		<$> liftIO (S.readFile merge_head)
 	ifM (resolveMerge (Just us) them False)
 		( do

Command/SetKey.hs

@@ -44,7 +44,7 @@ perform file key = do
 		else return True
 	if ok
 		then next $ cleanup key
-		else error "mv failed!"
+		else giveup "move failed!"
 
 cleanup :: Key -> CommandCleanup
 cleanup key = do

Command/Smudge.hs

@@ -191,7 +191,7 @@ clean' file mk passthrough discardreststdin emitpointer =
 	postingest (Just k, _) = do
 		logStatus k InfoPresent
 		return k
-	postingest _ = error "could not add file to the annex"
+	postingest _ = giveup "could not add file to the annex"
 
 	cfg = LockDownConfig
 		{ lockingFile = False

Command/TestRemote.hs

@@ -152,7 +152,7 @@ encryptionVariants cache dr = [noenc, sharedenc]
 
 -- Variant of a remote with exporttree disabled.
 disableExportTree :: RemoteVariantCache -> Remote -> Annex Remote
-disableExportTree cache r = maybe (error "failed disabling exportree") return 
+disableExportTree cache r = maybe (giveup "failed disabling exportree") return 
 		=<< adjustRemoteConfig cache r (M.delete exportTreeField)
 
 -- Variant of a remote with exporttree enabled.

Command/TransferKeys.hs

@@ -83,7 +83,7 @@ runRequests readh writeh a = do
 		go rest
 	go [] = noop
 	go [""] = noop
-	go v = error $ "transferkeys protocol error: " ++ show v
+	go v = giveup $ "transferkeys protocol error: " ++ show v
 
 	readrequests = liftIO $ split fieldSep <$> hGetContents readh
 	sendresult b = liftIO $ do

Command/Undo.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Command.Undo where
 
 import Command

Command/Unlock.hs

@@ -58,7 +58,7 @@ perform dest key = do
 				case r of
 					LinkAnnexOk -> return ()
 					LinkAnnexNoop -> return ()
-					LinkAnnexFailed -> error "unlock failed"
+					LinkAnnexFailed -> giveup "unlock failed"
 			, liftIO $ writePointerFile (toRawFilePath tmp) key destmode
 			)
 		withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))

Command/Whereis.hs

@@ -17,7 +17,6 @@ import Remote.Web (getWebUrls)
 import Annex.UUID
 import qualified Utility.Format
 import qualified Command.Find
-import Types.ActionItem
 
 import qualified Data.Map as M
 import qualified Data.Vector as V

Creds.hs

@@ -150,7 +150,7 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
 			writeCacheCredPair credpair storage
 
 			return $ Just credpair
-		_ -> error "bad creds"
+		_ -> giveup "bad creds"
 
 getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
 getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage

Crypto.hs

@@ -73,7 +73,7 @@ cipherSize = 512
 
 cipherPassphrase :: Cipher -> String
 cipherPassphrase (Cipher c) = drop cipherBeginning c
-cipherPassphrase (MacOnlyCipher _) = error "MAC-only cipher"
+cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher"
 
 cipherMac :: Cipher -> String
 cipherMac (Cipher c) = take cipherBeginning c

Database/Benchmark.hs

@@ -44,7 +44,7 @@ benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do
 			]
 		]
 #else
-benchmarkDbs _ = error "not built with criterion, cannot benchmark"
+benchmarkDbs _ = giveup "not built with criterion, cannot benchmark"
 #endif
 
 #ifdef WITH_BENCHMARK

Database/Handle.hs

@@ -84,7 +84,7 @@ queryDb (DbHandle _db _ jobs errvar) a = do
 		Right r -> either throwIO return r
 		Left BlockedIndefinitelyOnMVar -> do
 			err <- takeMVar errvar
-			error $ "sqlite worker thread crashed: " ++ err
+			giveup $ "sqlite worker thread crashed: " ++ err
 
 {- Writes a change to the database.
  -

Git.hs

@@ -68,7 +68,7 @@ repoLocation Repo { location = UnparseableUrl url } = url
 repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir
 repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir
 repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir
-repoLocation Repo { location = Unknown } = error "unknown repoLocation"
+repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"
 
 {- Path to a repository. For non-bare, this is the worktree, for bare, 
  - it's the gitdir, and for URL repositories, is the path on the remote
@@ -78,8 +78,8 @@ repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u
 repoPath Repo { location = Local { worktree = Just d } } = d
 repoPath Repo { location = Local { gitdir = d } } = d
 repoPath Repo { location = LocalUnknown dir } = dir
-repoPath Repo { location = Unknown } = error "unknown repoPath"
+repoPath Repo { location = Unknown } = giveup "unknown repoPath"
-repoPath Repo { location = UnparseableUrl _u } = error "unknown repoPath"
+repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"
 
 repoWorkTree :: Repo -> Maybe RawFilePath
 repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
@@ -88,7 +88,7 @@ repoWorkTree _ = Nothing
 {- Path to a local repository's .git directory. -}
 localGitDir :: Repo -> RawFilePath
 localGitDir Repo { location = Local { gitdir = d } } = d
-localGitDir _ = error "unknown localGitDir"
+localGitDir _ = giveup "unknown localGitDir"
 
 {- Some code needs to vary between URL and normal repos,
  - or bare and non-bare, these functions help with that. -}
@@ -129,7 +129,7 @@ repoIsLocalUnknown _ = False
 
 assertLocal :: Repo -> a -> a
 assertLocal repo action
-	| repoIsUrl repo = error $ unwords
+	| repoIsUrl repo = giveup $ unwords
 		[ "acting on non-local git repo"
 		, repoDescribe repo
 		, "not supported"

Git/CatFile.hs

@@ -120,7 +120,7 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f
 			content <- readObjectContent from r
 			return $ Just (content, sha, objtype)
 		Just DNE -> return Nothing
-		Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
+		Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object)
   where
 	-- Slow fallback path for filenames containing newlines.
 	newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case
@@ -144,7 +144,7 @@ readObjectContent h (ParsedResp _ _ size) = do
 	eatchar expected = do
 		c <- hGetChar h
 		when (c /= expected) $
-			error $ "missing " ++ (show expected) ++ " from git cat-file"
+			giveup $ "missing " ++ (show expected) ++ " from git cat-file"
 readObjectContent _ DNE = error "internal"
 
 {- Gets the size and type of an object, without reading its content. -}

Git/CheckAttr.hs

@@ -54,7 +54,7 @@ checkAttrs (h, attrs, currdir) want file = do
 	getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
 			["unspecified"] -> "" : getvals l xs
 			[v] -> v : getvals l xs
-			_ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
+			_ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
 
 	send to = B.hPutStr to $ file' `B.snoc` 0
 	receive c from = do

Git/Construct.hs

@@ -86,7 +86,7 @@ fromAbsPath :: RawFilePath -> IO Repo
 fromAbsPath dir
 	| absoluteGitPath dir = fromPath dir
 	| otherwise =
-		error $ "internal error, " ++ show dir ++ " is not absolute"
+		giveup $ "internal error, " ++ show dir ++ " is not absolute"
 
 {- Construct a Repo for a remote's url.
  -

Git/DiffTree.hs

@@ -113,8 +113,8 @@ parseDiffRaw l = go l
 	go [] = []
 	go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of
 		A.Done _ r -> r : go rest
-		A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err
+		A.Fail _ _ err -> giveup $ "diff-tree parse error: " ++ err
-	go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""
+	go (s:[]) = giveup $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""
 
 -- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
 --

Git/PktLine.hs

@@ -31,6 +31,7 @@ import Text.Printf
 
 import Utility.PartialPrelude
 import Utility.FileSystemEncoding
+import Utility.Exception
 
 {- This is a variable length binary string, but its size is limited to
  - maxPktLineLength. Its serialization includes a 4 byte hexadecimal
@@ -96,7 +97,7 @@ encodePktLine b
 stringPktLine :: String -> PktLine
 stringPktLine s
 	| length s > maxPktLineLength =
-		error "textPktLine called with too-long value"
+		giveup "textPktLine called with too-long value"
 	| otherwise = PktLine (encodeBS s <> "\n")
 
 {- Sends a PktLine to a Handle, and flushes it so that it will be

Git/Sha.hs

@@ -20,7 +20,7 @@ import Data.Char
 getSha :: String -> IO S.ByteString -> IO Sha
 getSha subcommand a = maybe bad return =<< extractSha <$> a
   where
-	bad = error $ "failed to read sha from git " ++ subcommand
+	bad = giveup $ "failed to read sha from git " ++ subcommand
 
 {- Extracts the Sha from a ByteString. 
  -

Git/Tree.hs

@@ -62,7 +62,7 @@ data TreeContent
 getTree :: LsTree.LsTreeRecursive -> Ref -> Repo -> IO Tree
 getTree recursive r repo = do
 	(l, cleanup) <- lsTreeWithObjects recursive r repo
-	let !t = either (\e -> error ("ls-tree parse error:" ++ e)) id
+	let !t = either (\e -> giveup ("ls-tree parse error:" ++ e)) id
 		(extractTree l)
 	void cleanup
 	return t
@@ -254,7 +254,7 @@ adjustTree adjusttreeitem addtreeitems resolveaddconflict removefiles r repo =
 					Just (TreeItem f m s) -> 
 						let commit = TreeCommit f m s
 						in go h wasmodified (commit:c) depth intree is
-			_ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
+			_ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")
 		| otherwise = return (c, wasmodified, i:is)
 
 	adjustlist h depth ishere underhere l = do

Git/UnionMerge.hs

@@ -78,7 +78,7 @@ doMerge hashhandle ch differ repo streamer = do
 	go [] = noop
 	go (info:file:rest) = mergeFile info file hashhandle ch >>=
 		maybe (go rest) (\l -> streamer l >> go rest)
-	go (_:[]) = error $ "parse error " ++ show differ
+	go (_:[]) = giveup $ "parse error " ++ show differ
 
 {- Given an info line from a git raw diff, and the filename, generates
  - a line suitable for update-index that union merges the two sides of the

Limit.hs

@@ -87,7 +87,7 @@ add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
 
 {- Adds a new syntax token. -}
 addSyntaxToken :: String -> Annex ()
-addSyntaxToken = either error add . Utility.Matcher.syntaxToken
+addSyntaxToken = either giveup add . Utility.Matcher.syntaxToken
 
 {- Adds a new limit. -}
 addLimit :: Either String (MatchFiles Annex) -> Annex ()

Messages/Internal.hs

@@ -105,4 +105,4 @@ outputSerialized = id
 waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO ()
 waitOutputSerializedResponse getr r = tryIO getr >>= \case
 	Right (Just r') | r' == r -> return ()
-	v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
+	v -> giveup $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v

P2P/Annex.hs

@@ -225,7 +225,7 @@ runLocal runst runner a = case a of
 						-- known. Force content
 						-- verification.
 						return (rightsize, MustVerify)
-			Left e -> error $ describeProtoFailure e
+			Left e -> giveup $ describeProtoFailure e
 	
 	sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go
 	  where

Remote/BitTorrent.hs

@@ -47,7 +47,7 @@ remote = RemoteType
 	, enumerate = list
 	, generate = gen
 	, configParser = mkRemoteConfigParser []
-	, setup = error "not supported"
+	, setup = giveup "not supported"
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
 	, thirdPartyPopulated = False

Remote/Ddar.hs

@@ -139,7 +139,7 @@ store ddarrepo = fileStorer $ \k src _p -> do
 
 {- Convert remote DdarRepo to host and path on remote end -}
 splitRemoteDdarRepo :: DdarRepo -> (SshHost, String)
-splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo')
+splitRemoteDdarRepo ddarrepo = (either giveup id $ mkSshHost host, ddarrepo')
   where
 	(host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo)
 	ddarrepo' = drop 1 remainder
@@ -228,7 +228,7 @@ checkKey ddarrepo key = do
 	directoryExists <- ddarDirectoryExists ddarrepo
 	case directoryExists of
 		Left e -> error e
-		Right True -> either error return
+		Right True -> either giveup return
 			=<< inDdarManifest ddarrepo key
 		Right False -> return False
 

Remote/GCrypt.hs

@@ -197,7 +197,7 @@ rsyncTransport r gc
 		let rsyncpath = if "/~/" `isPrefixOf` path
 			then drop 3 path
 			else path
-		    sshhost = either error id (mkSshHost host)
+		    sshhost = either giveup id (mkSshHost host)
 		    mkopts = rsyncShell . (Param "ssh" :) 
 			<$> sshOptions ConsumeStdin (sshhost, Nothing) gc []
 		in (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessGitAnnexShell)
@@ -239,7 +239,7 @@ gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c
 				]
 			(r:_)
 				| Git.repoLocation r == url -> noop
-				| otherwise -> error "Another remote with the same name already exists."		
+				| otherwise -> giveup "Another remote with the same name already exists."		
 
 		pc <- either giveup return . parseRemoteConfig c'
 			=<< configParser remote c'
@@ -505,7 +505,7 @@ getGCryptId fast r gc
 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
 		liftIO (catchMaybeIO $ Git.Config.read r)
 	| not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>)
-		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ error "configlist failed")) "configlist" [] []
+		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ giveup "configlist failed")) "configlist" [] []
 		, getConfigViaRsync r gc
 		]
 	| otherwise = return (Nothing, r)

Remote/Helper/Encryptable.hs

@@ -331,4 +331,4 @@ toB64bs = w82s . B.unpack . B64.encode . B.pack . s2w8
 fromB64bs :: String -> String
 fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)
   where
-	bad = error "bad base64 encoded data"
+	bad = giveup "bad base64 encoded data"

Remote/Helper/Ssh.hs

@@ -32,7 +32,7 @@ toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (Fi
 toRepo cs r gc remotecmd = do
 	let host = maybe
 		(giveup "bad ssh url")
-		(either error id . mkSshHost)
+		(either giveup id . mkSshHost)
 		(Git.Url.hostuser r)
 	sshCommand cs (host, Git.Url.port r) gc remotecmd
 

Remote/HttpAlso.hs

@@ -103,7 +103,7 @@ cannotModify = giveup "httpalso special remote is read only"
 
 httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
 httpAlsoSetup _ Nothing _ _ _ =
-	error "Must use --sameas when initializing a httpalso remote."
+	giveup "Must use --sameas when initializing a httpalso remote."
 httpAlsoSetup _ (Just u) _ c gc = do
 	_url <- maybe (giveup "Specify url=")
 		(return . fromProposedAccepted)

Remote/P2P.hs

@@ -38,7 +38,7 @@ remote = RemoteType
 	, enumerate = const (return [])
 	, generate = \_ _ _ _ _ -> return Nothing
 	, configParser = mkRemoteConfigParser []
-	, setup = error "P2P remotes are set up using git-annex p2p"
+	, setup = giveup "P2P remotes are set up using git-annex p2p"
 	, exportSupported = exportUnsupported
 	, importSupported = importUnsupported
 	, thirdPartyPopulated = False

Remote/Rsync.hs

@@ -179,7 +179,7 @@ rsyncTransport gc url
 		case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of
 			"ssh":sshopts -> do
 				let (port, sshopts') = sshReadPort sshopts
-				    userhost = either error id $ mkSshHost $ 
+				    userhost = either giveup id $ mkSshHost $ 
 				    	takeWhile (/= ':') url
 				return $ (Param "ssh":) <$> sshOptions ConsumeStdin
 					(userhost, port) gc

Remote/WebDAV.hs

@@ -321,7 +321,7 @@ testDav url (Just (u, p)) = do
 
 	user = toDavUser u
 	pass = toDavPass p
-testDav _ Nothing = error "Need to configure webdav username and password."
+testDav _ Nothing = giveup "Need to configure webdav username and password."
 
 {- Tries to make all the parent directories in the WebDAV urls's path,
  - right down to the root.
@@ -407,7 +407,7 @@ choke :: IO (Either String a) -> IO a
 choke f = do
 	x <- f
 	case x of
-		Left e -> error e
+		Left e -> giveup e
 		Right r -> return r
 
 data DavHandle = DavHandle DAVContext DavUser DavPass URLString
@@ -491,11 +491,11 @@ retrieveLegacyChunked d k p dav = liftIO $
 				inLocation l $
 					snd <$> getContentM
   where
-	onerr = error "download failed"
+	onerr = giveup "download failed"
 
 checkKeyLegacyChunked :: DavHandle -> CheckPresent
 checkKeyLegacyChunked dav k = liftIO $
-	either error id <$> withStoredFilesLegacyChunked k dav onerr check
+	either giveup id <$> withStoredFilesLegacyChunked k dav onerr check
   where
 	check [] = return $ Right True
 	check (l:ls) = do

RemoteDaemon/Core.hs

@@ -40,7 +40,7 @@ runInteractive = do
 	let reader = forever $ do
 		l <- hGetLine readh
 		case parseMessage l of
-			Nothing -> error $ "protocol error: " ++ l
+			Nothing -> giveup $ "protocol error: " ++ l
 			Just cmd -> atomically $ writeTChan ichan cmd
 	let writer = forever $ do
 		msg <- atomically $ readTChan ochan

Test.hs

@@ -239,7 +239,7 @@ testRemote testvariants remotetype setupremote =
 		innewrepo $ do
 			git_annex "init" [reponame, "--quiet"] "init"
 			setupremote remotename
-			r <- annexeval $ either error return 
+			r <- annexeval $ either giveup return 
 				=<< Remote.byName' remotename
 			cache <- Command.TestRemote.newRemoteVariantCache
 			unavailr <- annexeval $ Types.Remote.mkUnavailable r

Utility/AuthToken.hs

@@ -20,6 +20,7 @@ module Utility.AuthToken (
 
 import qualified Utility.SimpleProtocol as Proto
 import Utility.Hash
+import Utility.Exception
 
 import Data.SecureMem
 import Data.Maybe
@@ -79,8 +80,8 @@ genAuthToken len = do
 	g <- newGenIO :: IO SystemRandom
 	return $
 		case genBytes 512 g of
-			Left e -> error $ "failed to generate auth token: " ++ show e
+			Left e -> giveup $ "failed to generate auth token: " ++ show e
-			Right (s, _) -> fromMaybe (error "auth token encoding failed") $
+			Right (s, _) -> fromMaybe (giveup "auth token encoding failed") $
 				toAuthToken $ T.pack $ take len $
 					show $ sha2_512 $ L.fromChunks [s]
 

Utility/Base64.hs

@@ -11,6 +11,7 @@ module Utility.Base64 where
 
 import Utility.FileSystemEncoding
 import Utility.QuickCheck
+import Utility.Exception
 
 import qualified "sandi" Codec.Binary.Base64 as B64
 import Data.Maybe
@@ -36,12 +37,12 @@ fromB64Maybe' = either (const Nothing) Just . B64.decode
 fromB64 :: String -> String
 fromB64 = fromMaybe bad . fromB64Maybe
   where
-	bad = error "bad base64 encoded data"
+	bad = giveup "bad base64 encoded data"
 
 fromB64' :: B.ByteString -> B.ByteString
 fromB64' = fromMaybe bad . fromB64Maybe'
   where
-	bad = error "bad base64 encoded data"
+	bad = giveup "bad base64 encoded data"
 
 -- Only ascii strings are tested, because an arbitrary string may contain
 -- characters not encoded using the FileSystemEncoding, which would thus

Utility/Exception.hs

@@ -36,13 +36,17 @@ import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
 import GHC.IO.Exception (IOErrorType(..))
 
 import Utility.Data
+import Utility.SafeOutput
 
 {- Like error, this throws an exception. Unlike error, if this exception
  - is not caught, it won't generate a backtrace. So use this for situations
  - where there's a problem that the user is expected to see in some
- - circumstances. -}
+ - circumstances.
+ -
+ - Also, control characters are filtered out of the message.
+ -}
 giveup :: [Char] -> a
-giveup = errorWithoutStackTrace
+giveup = errorWithoutStackTrace . safeOutput
 
 {- Catches IO errors and returns a Bool -}
 catchBoolIO :: MonadCatch m => m Bool -> m Bool

Utility/Lsof.hs

@@ -110,4 +110,4 @@ parse s = bundle $ go [] $ lines s
 
 	splitnull = splitc '\0'
 
-	parsefail = error $ "failed to parse lsof output: " ++ show s
+	parsefail = giveup $ "failed to parse lsof output: " ++ show s

Utility/SafeOutput.hs

@@ -0,0 +1,24 @@
+{- Safe output to the terminal of possibly attacker-controlled strings,
+ - avoiding displaying control characters.
+ -
+ - Copyright 2023 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.SafeOutput (safeOutput) where
+
+import Data.Char
+import qualified Data.ByteString as S
+
+class SafeOutputtable t where
+	safeOutput :: t -> t
+
+instance SafeOutputtable String where
+	safeOutput = filter (not . isControl)
+
+instance SafeOutputtable S.ByteString where
+	safeOutput = S.filter (not . isControl . chr . fromIntegral)

Utility/WebApp.hs

@@ -87,7 +87,7 @@ getSocket h = do
 	-- getAddrInfo didn't used to work on windows; current status
 	-- unknown.
 	when (isJust h) $
-		error "getSocket with HostName not supported on this OS"
+		giveup "getSocket with HostName not supported on this OS"
 	let addr = tupleToHostAddress (127,0,0,1)
 	sock <- socket AF_INET Stream defaultProtocol
 	preparesocket sock
@@ -99,7 +99,7 @@ getSocket h = do
 	case (partition (\a -> addrFamily a == AF_INET) addrs) of
 		(v4addr:_, _) -> go v4addr
 		(_, v6addr:_) -> go v6addr
-		_ -> error "unable to bind to a local socket"
+		_ -> giveup "unable to bind to a local socket"
   where
 	hostname = fromMaybe localhost h
 	localhost = "localhost"
@@ -108,7 +108,7 @@ getSocket h = do
 	 - unknown reason on OSX. -} 
 	go addr = go' 100 addr
 	go' :: Int -> AddrInfo -> IO Socket
-	go' 0 _ = error "unable to bind to local socket"
+	go' 0 _ = giveup "unable to bind to local socket"
 	go' n addr = do
 		r <- tryIO $ bracketOnError (open addr) close (useaddr addr)
 		either (const $ go' (pred n) addr) return r
@@ -129,9 +129,9 @@ webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend)
 webAppSessionBackend _ = do
 	g <- newGenIO :: IO SystemRandom
 	case genBytes 96 g of
-		Left e -> error $ "failed to generate random key: " ++ show e
+		Left e -> giveup $ "failed to generate random key: " ++ show e
 		Right (s, _) -> case CS.initKey s of
-			Left e -> error $ "failed to initialize key: " ++ show e
+			Left e -> giveup $ "failed to initialize key: " ++ show e
 			Right key -> use key
   where
 	timeout = 120 * 60 -- 120 minutes

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 error messages, warnings, info messages, still need to be done.
+> embedded in warnings, info messages, still need to be done.
 
 ----
 
@@ -59,3 +59,9 @@ out control characters. If such an url even can be parsed?
 
 Also: git-annex initremote with autoenable may be able to cause a remote
 with a malicious name to be set up?
+
+Also: Any place that an exception is thrown with an attacker-controlled value.
+`giveup` has been made to filter out control characters, but that leave
+other exceptions, including ones thrown by libraries. Catch all exceptions
+at top-level (of program and/or worker threads) and filter out control
+characters?

git-annex.cabal

@@ -1133,6 +1133,7 @@ Executable git-annex
     Utility.ResourcePool
     Utility.Rsync
     Utility.SafeCommand
+    Utility.SafeOutput
     Utility.Scheduled
     Utility.Scheduled.QuickCheck
     Utility.Shell