Work around problem with concurrent-output when in a non-unicode locale by avoiding use of it in such a locale.

Instead -J will behave as if it was built without concurrent-output support
in this situation. Ie, it will be mostly quiet, except when there's an
error.

Note that it's not a problem for a filename to contain invalid utf-8 when
in a utf-8 locale. That is handled ok by concurrent-output. It's only
displaying unicode characters in a non-unicode locale that doesn't work.

CmdLine/Action.hs

@@ -53,7 +53,7 @@ performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do
 commandAction :: CommandStart -> Annex ()
 commandAction a = withOutputType go 
   where
-	go (ConcurrentOutput n) = do
+	go o@(ConcurrentOutput n _) = do
 		ws <- Annex.getState Annex.workers
 		(st, ws') <- if null ws
 			then do
@@ -63,7 +63,7 @@ commandAction a = withOutputType go
 				l <- liftIO $ drainTo (n-1) ws
 				findFreeSlot l
 		w <- liftIO $ async
-			$ snd <$> Annex.run st (inOwnConsoleRegion run)
+			$ snd <$> Annex.run st (inOwnConsoleRegion o run)
 		Annex.changeState $ \s -> s { Annex.workers = Right w:ws' }
 	go _  =	run
 	run = void $ includeCommandAction a
@@ -155,9 +155,13 @@ allowConcurrentOutput :: Annex a -> Annex a
 allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs
   where
 	go Nothing = a
-	go (Just n) = Regions.displayConsoleRegions $
+	go (Just n) = ifM (liftIO concurrentOutputSupported)
-		bracket_ (setup n) cleanup a
+		( Regions.displayConsoleRegions $
-	setup = Annex.setOutput . ConcurrentOutput
+			goconcurrent (ConcurrentOutput n True)
+		, goconcurrent (ConcurrentOutput n False)
+		)
+	goconcurrent o = bracket_ (setup o) cleanup a
+	setup = Annex.setOutput
 	cleanup = do
 		finishCommandActions
 		Annex.setOutput NormalOutput

Messages.hs

@@ -212,7 +212,7 @@ commandProgressDisabled = withOutputType $ \t -> return $ case t of
 	QuietOutput -> True
 	JSONOutput -> True
 	NormalOutput -> False
-	ConcurrentOutput _ -> True
+	ConcurrentOutput {} -> True
 
 {- Use to show a message that is displayed implicitly, and so might be
  - disabled when running a certian command that needs more control over its

Messages/Concurrent.hs

@@ -1,13 +1,12 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {- git-annex output messages, including concurrent output to display regions
  -
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
 {-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Messages.Concurrent where
 
@@ -20,6 +19,7 @@ import qualified System.Console.Concurrent as Console
 import qualified System.Console.Regions as Regions
 import Control.Concurrent.STM
 import qualified Data.Text as T
+import GHC.IO.Encoding
 #endif
 
 {- Outputs a message in a concurrency safe way.
@@ -29,9 +29,14 @@ import qualified Data.Text as T
  - When built without concurrent-output support, the fallback action is run
  - instead.
  -}
-concurrentMessage :: Bool -> String -> Annex () -> Annex ()
+concurrentMessage :: OutputType -> Bool -> String -> Annex () -> Annex ()
+#ifdef WITH_CONCURRENTOUTPUT
+concurrentMessage o iserror msg fallback 
+	| concurrentOutputEnabled o =
+		go =<< consoleRegion <$> Annex.getState Annex.output
+#endif
+	| otherwise = fallback
 #ifdef WITH_CONCURRENTOUTPUT
-concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.output
   where
 	go Nothing
 		| iserror = liftIO $ Console.errorConcurrent msg
@@ -48,9 +53,6 @@ concurrentMessage iserror msg _ = go =<< consoleRegion <$> Annex.getState Annex.
 			rl <- takeTMVar Regions.regionList
 			putTMVar Regions.regionList
 				(if r `elem` rl then rl else r:rl)
-
-#else
-concurrentMessage _ _ fallback = fallback
 #endif
 
 {- Runs an action in its own dedicated region of the console.
@@ -62,21 +64,25 @@ concurrentMessage _ _ fallback = fallback
  - When not at a console, a region is not displayed until the action is
  - complete.
  -}
-inOwnConsoleRegion :: Annex a -> Annex a
+inOwnConsoleRegion :: OutputType -> Annex a -> Annex a
+inOwnConsoleRegion o a
 #ifdef WITH_CONCURRENTOUTPUT
-inOwnConsoleRegion a = do
+	| concurrentOutputEnabled o = do
 		r <- mkregion
 		setregion (Just r)
 		eret <- tryNonAsync a `onException` rmregion r
 		case eret of
 			Left e -> do
 				-- Add error message to region before it closes.
-			concurrentMessage True (show e) noop
+				concurrentMessage o True (show e) noop
 				rmregion r
 				throwM e
 			Right ret -> do
 				rmregion r
 				return ret
+#endif
+	| otherwise = a
+#ifdef WITH_CONCURRENTOUTPUT
   where
 	-- The region is allocated here, but not displayed until 
 	-- a message is added to it. This avoids unnecessary screen
@@ -94,8 +100,6 @@ inOwnConsoleRegion a = do
 			unless (T.null t) $
 				Console.bufferOutputSTM h t
 			Regions.closeConsoleRegion r
-#else
-inOwnConsoleRegion = id
 #endif
 
 {- The progress region is displayed inline with the current console region. -}
@@ -108,3 +112,24 @@ withProgressRegion a = do
 instance Regions.LiftRegion Annex where
 	liftRegion = liftIO . atomically
 #endif
+
+{- The concurrent-output library uses Text, which bypasses the normal use
+ - of the fileSystemEncoding to roundtrip invalid characters, when in a
+ - non-unicode locale. Work around that problem by avoiding using
+ - concurrent output when not in a unicode locale. -}
+concurrentOutputSupported :: IO Bool
+#ifdef WITH_CONCURRENTOUTPUT
+#ifndef mingw32_HOST_OS
+concurrentOutputSupported = do
+	enc <- getLocaleEncoding
+	return ("UTF" `isInfixOf` textEncodingName enc)
+#else
+concurrentOutputSupported = return True -- Windows is always unicode
+#endif
+#else
+concurrentOutputSupported = return False
+#endif
+
+concurrentOutputEnabled :: OutputType -> Bool
+concurrentOutputEnabled (ConcurrentOutput _ b) = b
+concurrentOutputEnabled _ = False

Messages/Internal.hs

@@ -21,13 +21,13 @@ outputMessage json s = withOutputType go
 	go NormalOutput = liftIO $
 		flushed $ putStr s
 	go QuietOutput = q
-	go (ConcurrentOutput _) = concurrentMessage False s q
+	go o@(ConcurrentOutput {}) = concurrentMessage o False s q
 	go JSONOutput = liftIO $ flushed json
 
 outputError :: String -> Annex ()
 outputError s = withOutputType go
   where
-	go (ConcurrentOutput _) = concurrentMessage True s (go NormalOutput)
+	go o@(ConcurrentOutput {}) = concurrentMessage o True s (go NormalOutput)
 	go _ = liftIO $ do
 		hFlush stdout
 		hPutStr stderr s

Messages/Progress.hs

@@ -46,16 +46,16 @@ metered combinemeterupdate key a = case keySize key of
 		liftIO $ clearMeter stdout meter
 		return r
 #if WITH_CONCURRENTOUTPUT
-	go size (ConcurrentOutput _) = withProgressRegion $ \r -> do
+	go size o@(ConcurrentOutput {})
+		| concurrentOutputEnabled o = withProgressRegion $ \r -> do
 			(progress, meter) <- mkmeter size
 			a $ \n -> liftIO $ do
 				setP progress $ fromBytesProcessed n
 				s <- renderMeter meter
 				Regions.setConsoleRegion r ("\n" ++ s)
 				maybe noop (\m -> m n) combinemeterupdate
-#else
-	go _ (ConcurrentOutput _) = nometer
 #endif
+		| otherwise = nometer
 
 	mkmeter size = do
 		progress <- liftIO $ newProgress "" size
@@ -69,14 +69,14 @@ metered combinemeterupdate key a = case keySize key of
 concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a
 concurrentMetered combinemeterupdate key a = withOutputType go
   where
-	go (ConcurrentOutput _) = metered combinemeterupdate key a
+	go (ConcurrentOutput {}) = metered combinemeterupdate key a
 	go _ = a (fromMaybe nullMeterUpdate combinemeterupdate)
 
 {- Poll file size to display meter, but only for concurrent output. -}
 concurrentMeteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a
 concurrentMeteredFile file combinemeterupdate key a = withOutputType go
   where
-	go (ConcurrentOutput _) = metered combinemeterupdate key $ \p ->
+	go (ConcurrentOutput {}) = metered combinemeterupdate key $ \p ->
 		watchFileSize file p a
 	go _ = a
 
@@ -120,6 +120,6 @@ mkStderrEmitter :: Annex (String -> IO ())
 mkStderrEmitter = withOutputType go
   where
 #ifdef WITH_CONCURRENTOUTPUT
-	go (ConcurrentOutput _) = return Console.errorConcurrent
+	go o | concurrentOutputEnabled o = return Console.errorConcurrent
 #endif
 	go _ = return (hPutStrLn stderr)

Types/Messages.hs

@@ -15,7 +15,7 @@ import Data.Default
 import System.Console.Regions (ConsoleRegion)
 #endif
 
-data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int | JSONOutput
+data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int Bool | JSONOutput
 	deriving (Show)
 
 data SideActionBlock = NoBlock | StartBlock | InBlock

debian/changelog

@@ -3,6 +3,9 @@ git-annex (6.20160212) UNRELEASED; urgency=medium
   * Support getting files from read-only repositories.
   * checkpresentkey: Allow to be run without an explicit remote.
   * checkpresentkey: Added --batch.
+  * Work around problem with concurrent-output when in a non-unicode locale
+    by avoiding use of it in such a locale. Instead -J will behave as if
+    it was built without concurrent-output support in this situation.
 
  -- Joey Hess <id@joeyh.name>  Fri, 12 Feb 2016 14:03:46 -0400
 

doc/bugs/Unable_to_parallel_fsck.mdwn

@@ -81,3 +81,8 @@ Plenty. In fact I've been using it for a long time - I just only recently tried
 
 
 [[!meta title="-J can crash on displaying filenames not supported by current locale"]]
+
+> I've worked around this by detecting the non-unicode locale and avoiding
+> the fancy concurrent output which needs it. So -J will work, just not
+> with concurrent progress. I think this is the best that can be done
+> reasonably, so [[done]]. --[[Joey]]