diff options
| author |  Joey Hess <joeyh@joeyh.name> | 2018-02-19 15:28:38 -0400 |
|---|---|---|
| committer | Joey Hess <joeyh@joeyh.name> | 2018-02-19 15:28:38 -0400 |
| commit | e8626258f0422fb6487e79c58e5f10d51a3c1737 (patch) | |
| tree | f7369bff2ce3716849438f9799d8be1e94a72e8c | |
| parent | 7f49e1b922d83fa6548c4c9357591b661cbf1c46 (diff) | |
send stderr to json when --json-error-messages enabled
| -rw-r--r-- | Messages/Internal.hs | 12 | ||||
| -rw-r--r-- | Messages/JSON.hs | 9 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 1 |
4 files changed, 17 insertions, 6 deletions
diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 3731af16d..734b146b3 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -60,10 +60,14 @@ outputJSON jsonbuilder s = case outputType s of _ -> return False outputError :: String -> Annex () -outputError msg = withMessageState $ \s -> - if concurrentOutputEnabled s - then concurrentMessage s True msg go - else go +outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of + (JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions -> + let jb' = Just (JSON.addErrorMessage [msg] jb) + in Annex.changeState $ \st -> + st { Annex.output = s { jsonBuffer = jb' } + _ + | concurrentOutputEnabled s -> concurrentMessage s True msg go + | otherwise -> go where go = liftIO $ do hFlush stdout diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 1fe989f7f..48e48ec73 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -15,6 +15,7 @@ module Messages.JSON ( start, end, finalize, + addErrorMessage, note, info, add, @@ -29,6 +30,7 @@ import Data.Aeson import Control.Applicative import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Vector as V import qualified Data.ByteString.Lazy as B import qualified Data.HashMap.Strict as HM import System.IO @@ -80,9 +82,12 @@ finalize :: JSONOptions -> Object -> Object finalize jsonoptions o -- Always include error-messages field, even if empty, -- to make the json be self-documenting. - | jsonErrorMessages jsonoptions = - HM.insertWith combinearray "error-messages" (Array mempty) o + | jsonErrorMessages jsonoptions = addErrorMessage [] o | otherwise = o + +addErrorMessage :: [String] -> Object -> Object +addErrorMessage msg o = + HM.insertWith combinearray "error-messages" (Array $ V.fromList msg ) o where combinearray (Array new) (Array old) = Array (old <> new) combinearray new _old = new diff --git a/debian/control b/debian/control index ee90a1149..e9fafef6a 100644 --- a/debian/control +++ b/debian/control @@ -77,6 +77,7 @@ Build-Depends: libghc-mountpoints-dev, libghc-magic-dev, libghc-socks-dev, + libghc-vector-dev, lsof [linux-any], ikiwiki, libimage-magick-perl, diff --git a/git-annex.cabal b/git-annex.cabal index b02ea2e14..68bd9f01f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -350,6 +350,7 @@ Executable git-annex persistent, persistent-template, aeson, + vector, tagsoup, unordered-containers, feed (>= 0.3.9), |