sanitize control characters in main thread fatal exceptions

Sponsored-by: Noam Kremen on Patreon

diff --git a/Messages.hs b/Messages.hs
index 3b260af3a6c8161fe0e457dcc693ff3bde63be22..c6d6022bc51540edc0171ae20bbfafa561ab6a19 100644 (file)
--- a/Messages.hs
+++ b/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

diff --git a/doc/todo/terminal_escapes_in_filenames.mdwn b/doc/todo/terminal_escapes_in_filenames.mdwn
index d06cf29d461321fc703af77473ea57f499bfd840..ed56ea37b0c9165ec0d546a74c01a0a5939075c2 100644 (file)
--- a/doc/todo/terminal_escapes_in_filenames.mdwn
+++ b/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]]

diff --git a/git-annex.hs b/git-annex.hs
index 4992f4c76ef00a2c6326cedeedefbec72ef7eb5e..89a9350b4062c55072ce0151a787059d72e735c7 100644 (file)
--- a/git-annex.hs
+++ b/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