factor out maybeAddJSONField

Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project
This commit is contained in:
Joey Hess 2023-05-08 16:03:34 -04:00
parent 3d8f93dc0a
commit a5d0c85ae1
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 22 additions and 18 deletions

View file

@ -12,11 +12,10 @@ import Annex.MetaData
import Annex.VectorClock import Annex.VectorClock
import Logs.MetaData import Logs.MetaData
import Annex.WorkTree import Annex.WorkTree
import Messages.JSON (JSONActionItem(..), AddJSONActionItemField(..))
import Types.Messages import Types.Messages
import Utility.Aeson
import Utility.SafeOutput import Utility.SafeOutput
import Limit import Limit
import Messages.JSON (JSONActionItem(..), eitherDecode)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map as M import qualified Data.Map as M
@ -127,9 +126,7 @@ perform c o k = case getSet o of
cleanup :: Key -> CommandCleanup cleanup :: Key -> CommandCleanup
cleanup k = do cleanup k = do
m <- getCurrentMetaData k m <- getCurrentMetaData k
case toJSON' (AddJSONActionItemField "fields" m) of maybeAddJSONField "fields" m
Object o -> maybeShowJSON $ AesonObject o
_ -> noop
showLongNote $ UnquotedString $ unlines $ concatMap showmeta $ showLongNote $ UnquotedString $ unlines $ concatMap showmeta $
map unwrapmeta (fromMetaData m) map unwrapmeta (fromMetaData m)
return True return True

View file

@ -18,8 +18,6 @@ import Utility.Metered
import Annex.WorkTree import Annex.WorkTree
import qualified Git import qualified Git
import qualified Annex import qualified Annex
import Utility.Aeson
import Messages.JSON (AddJSONActionItemField(..))
cmd :: Command cmd :: Command
cmd = withAnnexOptions [backendOption, jsonOptions] $ cmd = withAnnexOptions [backendOption, jsonOptions] $
@ -98,9 +96,7 @@ notAnnexed src a =
perform :: RawFilePath -> Key -> CommandPerform perform :: RawFilePath -> Key -> CommandPerform
perform src key = do perform src key = do
case toJSON' (AddJSONActionItemField "key" (serializeKey key)) of maybeAddJSONField "key" (serializeKey key)
Object o -> maybeShowJSON $ AesonObject o
_ -> noop
ifM move ifM move
( next $ cleanup key ( next $ cleanup key
, giveup "failed" , giveup "failed"

View file

@ -35,7 +35,6 @@ import Annex.BloomFilter
import qualified Database.Keys import qualified Database.Keys
import Annex.InodeSentinal import Annex.InodeSentinal
import Utility.Aeson import Utility.Aeson
import Messages.JSON (AddJSONActionItemField(..))
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Vector as V import qualified Data.Vector as V
@ -115,11 +114,9 @@ check fileprefix msg a c = do
let unusedlist = number c l let unusedlist = number c l
unless (null l) $ unless (null l) $
showLongNote $ UnquotedString $ msg unusedlist showLongNote $ UnquotedString $ msg unusedlist
let v = V.fromList $ map (\(n, k) -> (show n, serializeKey k)) unusedlist maybeAddJSONField
let f = (if null fileprefix then "unused" else fileprefix) ++ "-list" ((if null fileprefix then "unused" else fileprefix) ++ "-list")
case toJSON' (AddJSONActionItemField f v) of (V.fromList $ map (\(n, k) -> (show n, serializeKey k)) unusedlist)
Object o -> maybeShowJSON $ AesonObject o
_ -> noop
updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist) updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist)
return $ c + length l return $ c + length l

View file

@ -37,6 +37,7 @@ module Messages (
JSON.JSONChunk(..), JSON.JSONChunk(..),
maybeShowJSON, maybeShowJSON,
maybeShowJSON', maybeShowJSON',
maybeAddJSONField,
showFullJSON, showFullJSON,
showCustom, showCustom,
showHeader, showHeader,
@ -227,6 +228,12 @@ maybeShowJSON v = void $ withMessageState $ bufferJSON (JSON.add v)
maybeShowJSON' :: JSON.JSONBuilder -> Annex () maybeShowJSON' :: JSON.JSONBuilder -> Annex ()
maybeShowJSON' v = void $ withMessageState $ bufferJSON v maybeShowJSON' v = void $ withMessageState $ bufferJSON v
{- Adds a field to the current json object. -}
maybeAddJSONField :: JSON.ToJSON' v => String -> v -> Annex ()
maybeAddJSONField f v = case JSON.toJSON' (JSON.AddJSONActionItemField f v) of
JSON.Object o -> maybeShowJSON $ JSON.AesonObject o
_ -> noop
{- Shows a complete JSON value, only when in json mode. -} {- Shows a complete JSON value, only when in json mode. -}
showFullJSON :: JSON.JSONChunk v -> Annex Bool showFullJSON :: JSON.JSONChunk v -> Annex Bool
showFullJSON v = withMessageState $ bufferJSON (JSON.complete v) showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)

View file

@ -12,7 +12,6 @@ module Messages.JSON (
JSONChunk(..), JSONChunk(..),
emit, emit,
emit', emit',
encode,
none, none,
start, start,
startActionItem, startActionItem,
@ -29,6 +28,7 @@ module Messages.JSON (
ObjectMap(..), ObjectMap(..),
JSONActionItem(..), JSONActionItem(..),
AddJSONActionItemField(..), AddJSONActionItemField(..),
module Utility.Aeson,
) where ) where
import Control.Applicative import Control.Applicative

View file

@ -45,7 +45,6 @@ Provisional list of commands that don't support --json and maybe should:
* git-annex-initremote * git-annex-initremote
* git-annex-merge * git-annex-merge
* git-annex-renameremote * git-annex-renameremote
* git-annex-sync
* git-annex-upgrade * git-annex-upgrade
These commands could support json, but I punted: These commands could support json, but I punted:
@ -113,3 +112,11 @@ These commands have been reviewed and should not support json:
(no output that would be useful to a program using these. They enter a (no output that would be useful to a program using these. They enter a
new branch and git branch will tell what it is.) new branch and git branch will tell what it is.)
* git-annex-inprogress (output is already machine readable) * git-annex-inprogress (output is already machine readable)
* git-annex-sync (while it would be pretty easy to support, it outputs
different types of messages depending on what remotes it syncs with and
what needs to be done. Eg, copy to remote, or export to remote, or import
from remote. Each would be a different format of json message, which
violates the principle that all git-annex json output should be
discoverable by simply running the command. And of course, everything it
does can be done by other commands, which can support json without having
that problem.)