send stderr to json when --json-error-messages enabled
This commit is contained in:
		
					parent
					
						
							
								63ff670cc5
							
						
					
				
			
			
				commit
				
					
						39b59c341f
					
				
			
		
					 4 changed files with 17 additions and 6 deletions
				
			
		| 
						 | 
					@ -60,10 +60,14 @@ outputJSON jsonbuilder s = case outputType s of
 | 
				
			||||||
	_ -> return False
 | 
						_ -> return False
 | 
				
			||||||
 | 
					
 | 
				
			||||||
outputError :: String -> Annex ()
 | 
					outputError :: String -> Annex ()
 | 
				
			||||||
outputError msg = withMessageState $ \s ->
 | 
					outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
 | 
				
			||||||
	if concurrentOutputEnabled s
 | 
					        (JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->
 | 
				
			||||||
		then concurrentMessage s True msg go
 | 
							let jb' = Just (JSON.addErrorMessage [msg] jb)
 | 
				
			||||||
		else go
 | 
							in Annex.changeState $ \st ->
 | 
				
			||||||
 | 
								st { Annex.output = s { jsonBuffer = jb' }
 | 
				
			||||||
 | 
						_
 | 
				
			||||||
 | 
							| concurrentOutputEnabled s -> concurrentMessage s True msg go
 | 
				
			||||||
 | 
							| otherwise -> go
 | 
				
			||||||
  where
 | 
					  where
 | 
				
			||||||
	go = liftIO $ do
 | 
						go = liftIO $ do
 | 
				
			||||||
		hFlush stdout
 | 
							hFlush stdout
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -15,6 +15,7 @@ module Messages.JSON (
 | 
				
			||||||
	start,
 | 
						start,
 | 
				
			||||||
	end,
 | 
						end,
 | 
				
			||||||
	finalize,
 | 
						finalize,
 | 
				
			||||||
 | 
						addErrorMessage,
 | 
				
			||||||
	note,
 | 
						note,
 | 
				
			||||||
	info,
 | 
						info,
 | 
				
			||||||
	add,
 | 
						add,
 | 
				
			||||||
| 
						 | 
					@ -29,6 +30,7 @@ import Data.Aeson
 | 
				
			||||||
import Control.Applicative
 | 
					import Control.Applicative
 | 
				
			||||||
import qualified Data.Map as M
 | 
					import qualified Data.Map as M
 | 
				
			||||||
import qualified Data.Text as T
 | 
					import qualified Data.Text as T
 | 
				
			||||||
 | 
					import qualified Data.Vector as V
 | 
				
			||||||
import qualified Data.ByteString.Lazy as B
 | 
					import qualified Data.ByteString.Lazy as B
 | 
				
			||||||
import qualified Data.HashMap.Strict as HM
 | 
					import qualified Data.HashMap.Strict as HM
 | 
				
			||||||
import System.IO
 | 
					import System.IO
 | 
				
			||||||
| 
						 | 
					@ -80,9 +82,12 @@ finalize :: JSONOptions -> Object -> Object
 | 
				
			||||||
finalize jsonoptions o
 | 
					finalize jsonoptions o
 | 
				
			||||||
	-- Always include error-messages field, even if empty,
 | 
						-- Always include error-messages field, even if empty,
 | 
				
			||||||
	-- to make the json be self-documenting.
 | 
						-- to make the json be self-documenting.
 | 
				
			||||||
	| jsonErrorMessages jsonoptions = 
 | 
						| jsonErrorMessages jsonoptions = addErrorMessage [] o
 | 
				
			||||||
		HM.insertWith combinearray "error-messages" (Array mempty) o
 | 
					 | 
				
			||||||
	| otherwise = o
 | 
						| otherwise = o
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					addErrorMessage :: [String] -> Object -> Object
 | 
				
			||||||
 | 
					addErrorMessage msg o =
 | 
				
			||||||
 | 
						HM.insertWith combinearray "error-messages" (Array $ V.fromList msg ) o
 | 
				
			||||||
  where
 | 
					  where
 | 
				
			||||||
	combinearray (Array new) (Array old) = Array (old <> new)
 | 
						combinearray (Array new) (Array old) = Array (old <> new)
 | 
				
			||||||
	combinearray new _old = new
 | 
						combinearray new _old = new
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
							
								
								
									
										1
									
								
								debian/control
									
										
									
									
										vendored
									
									
								
							
							
						
						
									
										1
									
								
								debian/control
									
										
									
									
										vendored
									
									
								
							| 
						 | 
					@ -77,6 +77,7 @@ Build-Depends:
 | 
				
			||||||
	libghc-mountpoints-dev,
 | 
						libghc-mountpoints-dev,
 | 
				
			||||||
	libghc-magic-dev,
 | 
						libghc-magic-dev,
 | 
				
			||||||
	libghc-socks-dev,
 | 
						libghc-socks-dev,
 | 
				
			||||||
 | 
						libghc-vector-dev,
 | 
				
			||||||
	lsof [linux-any],
 | 
						lsof [linux-any],
 | 
				
			||||||
	ikiwiki,
 | 
						ikiwiki,
 | 
				
			||||||
	libimage-magick-perl,
 | 
						libimage-magick-perl,
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -350,6 +350,7 @@ Executable git-annex
 | 
				
			||||||
   persistent,
 | 
					   persistent,
 | 
				
			||||||
   persistent-template,
 | 
					   persistent-template,
 | 
				
			||||||
   aeson,
 | 
					   aeson,
 | 
				
			||||||
 | 
					   vector,
 | 
				
			||||||
   tagsoup,
 | 
					   tagsoup,
 | 
				
			||||||
   unordered-containers,
 | 
					   unordered-containers,
 | 
				
			||||||
   feed (>= 0.3.9),
 | 
					   feed (>= 0.3.9),
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue