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

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)