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

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
-			Right (s, _) -> fromMaybe (error "auth token encoding failed") $
+			Left e -> giveup $ "failed to generate auth token: " ++ show e
+			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