sanitize control characters in main thread fatal exceptions

Sponsored-by: Noam Kremen on Patreon

Messages.hs

@@ -48,12 +48,14 @@ module Messages (
 	MessageState,
 	prompt,
 	mkPrompter,
+	sanitizeTopLevelExceptionMessages,
 ) where
 
 import Control.Concurrent
 import Control.Monad.IO.Class
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
+import System.Exit
 
 import Common
 import Types
@@ -323,3 +325,13 @@ mkPrompter = getConcurrency >>= \case
 				(takeMVar l)
 				(\v -> putMVar l v >> cleanup)
 				(const $ run a)
+
+{- Catch all (non-async) exceptions and display, santizing any control
+ - characters in the exceptions. Exits nonzero on exception, so should only
+ - be used at topmost level. -}
+sanitizeTopLevelExceptionMessages :: IO a -> IO a
+sanitizeTopLevelExceptionMessages a = catchNonAsync a go
+  where
+	go e = do
+		warningIO (show e)
+		exitWith $ ExitFailure 1

doc/todo/terminal_escapes_in_filenames.mdwn

@@ -60,3 +60,11 @@ Also: Any place that an exception is thrown with an attacker-controlled value.
 other exceptions, including ones thrown by libraries. Catch all exceptions
 at top-level (of program and/or worker threads) and filter out control
 characters?
+
+> Fixed with a top-level exception catcher; assuming all worker threads
+> have something waiting on them that displays or propagates their
+> exceptions.
+
+----
+
+> all [[fixed|done]]! --[[Joey]]

git-annex.hs

@@ -16,6 +16,7 @@ import qualified CmdLine.GitAnnexShell
 import qualified CmdLine.GitRemoteTorAnnex
 import qualified Test
 import qualified Benchmark
+import Messages
 import Utility.FileSystemEncoding
 
 #ifdef mingw32_HOST_OS
@@ -24,7 +25,7 @@ import Utility.Env.Set
 #endif
 
 main :: IO ()
-main = withSocketsDo $ do
+main = sanitizeTopLevelExceptionMessages $ withSocketsDo $ do
 	useFileSystemEncoding
 	ps <- getArgs
 #ifdef mingw32_HOST_OS