saner format for metadata --json

metadata --json output format has changed, adding a inner json object
named "fields" which contains only the fields and their values.

This should be easier to parse than the old format, which mixed up
metadata fields with other keys in the json object.

Any consumers of the old format will need to be updated.

This adds a dependency on unordered-containers for parsing MetaData
from JSON, but it's a free dependency; aeson pulls in that library.

CHANGELOG

@@ -1,5 +1,10 @@
-git-annex (6.20160620) UNRELEASED; urgency=medium
+git-annex (6.20160726) UNRELEASED; urgency=medium
 
+  * metadata --json output format has changed, adding a inner json object
+    named "fields" which contains only the fields and their values.
+    This should be easier to parse than the old format, which mixed up
+    metadata fields with other keys in the json object.
+    Any consumers of the old format will need to be updated.
   * Added --branch option to copy, drop, fsck, get, metadata, mirror, move,
     and whereis commands. This option makes git-annex operate on files that
     are included in a specified branch (or other treeish).

Command/MetaData.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -10,9 +10,13 @@ module Command.MetaData where
 import Command
 import Annex.MetaData
 import Logs.MetaData
+import Messages.JSON (ParsedJSON(..))
 
 import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.UTF8 as BU
 import Data.Time.Clock.POSIX
+import Data.Aeson
 
 cmd :: Command
 cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ 
@@ -95,10 +99,38 @@ perform now o k = case getSet o of
 
 cleanup :: Key -> CommandCleanup
 cleanup k = do
-	l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k
+	m <- getCurrentMetaData k
-	maybeShowJSON (JSONObject l)
+	let Object o = toJSON (MetaDataFields m)
-	showLongNote $ unlines $ concatMap showmeta l
+	maybeShowJSON $ AesonObject o
+	showLongNote $ unlines $ concatMap showmeta $
+		map unwrapmeta (fromMetaData m)
 	return True
   where
 	unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v))
 	showmeta (f, vs) = map ((f ++ "=") ++) vs
+
+-- Metadata serialized to JSON in the field named "fields" of
+-- a larger object.
+newtype MetaDataFields = MetaDataFields MetaData
+	deriving (Show)
+
+instance ToJSON MetaDataFields where
+	toJSON (MetaDataFields m) = object [ (fieldsField, toJSON m) ]
+
+instance FromJSON MetaDataFields where
+	parseJSON (Object v) = do
+		f <- v .: fieldsField
+		case f of
+			Nothing -> return (MetaDataFields emptyMetaData)
+			Just v' -> MetaDataFields <$> parseJSON v'
+	parseJSON _ = fail "expected an object"
+
+fieldsField :: T.Text
+fieldsField = T.pack "fields"
+
+parseJSONInput :: String -> Maybe (Either FilePath Key, MetaData)
+parseJSONInput i = do
+	v <- decode (BU.fromString i)
+	case parsedAdded v of
+		Nothing -> return (parsedKeyfile v, emptyMetaData)
+		Just (MetaDataFields m) -> return (parsedKeyfile v, m)

Types/MetaData.hs

@@ -44,14 +44,32 @@ import Common
 import Utility.Base64
 import Utility.QuickCheck
 
+import qualified Data.Text as T
 import qualified Data.Set as S
 import qualified Data.Map as M
+import qualified Data.HashMap.Strict as HM
 import Data.Char
 import qualified Data.CaseInsensitive as CI
+import Data.Aeson
 
 newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue))
 	deriving (Show, Eq, Ord)
 
+instance ToJSON MetaData where
+	toJSON (MetaData m) = object $ map go (M.toList m)
+	  where
+		go (MetaField f, s) = (T.pack (CI.original f), toJSON s)
+
+instance FromJSON MetaData where
+	parseJSON (Object o) = do
+		l <- HM.toList <$> parseJSON (Object o)
+		MetaData . M.fromList <$> mapM go l
+	  where
+		go (t, l) = case mkMetaField (T.unpack t) of
+			Left e -> fail e
+			Right f -> (,) <$> pure f <*> parseJSON l
+	parseJSON _ = fail "expected an object"
+
 {- A metadata value can be currently be set (True), or may have been
  - set before and we're remembering it no longer is (False). -}
 newtype CurrentlySet = CurrentlySet Bool
@@ -64,6 +82,13 @@ newtype MetaField = MetaField (CI.CI String)
 data MetaValue = MetaValue CurrentlySet String
 	deriving (Read, Show)
 
+instance ToJSON MetaValue where
+	toJSON (MetaValue _ v) = toJSON v
+
+instance FromJSON MetaValue where
+	parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v)
+	parseJSON _  = fail "expected a string"
+
 {- Metadata values compare and order the same whether currently set or not. -}
 instance Eq MetaValue where
 	MetaValue _ a == MetaValue _ b = a == b

debian/control

@@ -25,6 +25,7 @@ Build-Depends:
 	libghc-uuid-dev,
 	libghc-json-dev,
 	libghc-aeson-dev,
+	libghc-unordered-containers-dev,
 	libghc-ifelse-dev,
 	libghc-bloomfilter-dev,
 	libghc-edit-distance-dev,

doc/git-annex-metadata.mdwn

@@ -71,6 +71,16 @@ When run without any -s or -t parameters, displays the current metadata.
   Enable JSON output. This is intended to be parsed by programs that use
   git-annex. Each line of output is a JSON object.
 
+  The format of the JSON objects changed in git-annex version 6.20160726.
+
+  Example of the new format:
+
+	{"command":"metadata","file":"foo","key":"...","fields":{"author":["bar"],...},"note":"...","success":true}
+
+  Example of the old format, which lacks the inner fields object:
+
+	{"command":"metadata","file":"foo","key":"...","author":["bar"],...,"note":"...","success":true}
+
 * `--all`
 
   Specify instead of a file to get/set metadata on all known keys.

git-annex.cabal

@@ -323,7 +323,7 @@ Executable git-annex
   Build-Depends:
    base (>= 4.5 && < 5.0),
    optparse-applicative (>= 0.11.0), 
-   containers (>= 0.5.0.0), 
+   containers (>= 0.5.0.0),
    exceptions (>= 0.6),
    QuickCheck (>= 2.1),
    stm (>= 2.3),
@@ -338,6 +338,7 @@ Executable git-annex
    time, old-locale,
    esqueleto, persistent-sqlite, persistent (<2.5), persistent-template,
    aeson,
+   unordered-containers,
    feed,
    regex-tdfa
   CC-Options: -Wall