basic json support

This includes a generic JSONStream library built on top of Text.JSON
(somewhat hackishly).

It would be possible to stream out a single json document describing
all actions, but it's probably better for consumers if they can expect
one json document per line, so I did it that way instead.

Output from external programs used for transferring files is not
currently hidden when outputting json, which probably makes it not very
useful there. This may be dealt with if there is demand for json
output for --get or --move to be parsable.

The version, status, and find subcommands have hand-crafted output and
don't do json. The whereis subcommand needs to be modified to produce
useful json.

9 files changed, 123 insertions, 22 deletions

diff --git a/Annex.hs b/Annex.hs
index fac5d27e4..f5c3e4de4 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -64,7 +64,7 @@ data AnnexState = AnnexState
 	, cipher :: Maybe Cipher
 	}
 
-data OutputType = NormalOutput | QuietOutput
+data OutputType = NormalOutput | QuietOutput | JSONOutput
 
 newState :: Git.Repo -> AnnexState
 newState gitrepo = AnnexState
diff --git a/Messages.hs b/Messages.hs
index b2c871ede..87d414f17 100644
--- a/Messages.hs
+++ b/Messages.hs
@@ -5,7 +5,22 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Messages where
+module Messages (
+	showStart,
+	showNote,
+	showAction,
+	showProgress,
+	showSideAction,
+	showOutput,
+	showLongNote,
+	showEndOk,
+	showEndFail,
+	showEndResult,
+	showErr,
+	warning,
+	indent,
+	setupConsole
+) where
 
 import Control.Monad.State (liftIO)
 import System.IO
@@ -13,21 +28,15 @@ import Data.String.Utils
 
 import Types
 import qualified Annex
-
-verbose :: Annex () -> Annex ()
-verbose a = do
-	output <- Annex.getState Annex.output
-	case output of
-		Annex.NormalOutput -> a
-		_ -> return ()
+import qualified Messages.JSON as JSON
 
 showStart :: String -> String -> Annex ()
-showStart command file = verbose $ liftIO $ do
+showStart command file = handle (JSON.start command file) $ do
 	putStr $ command ++ " " ++ file ++ " "
 	hFlush stdout
 
 showNote :: String -> Annex ()
-showNote s = verbose $ liftIO $ do
+showNote s = handle (JSON.note s) $ do
 	putStr $ "(" ++ s ++ ") "
 	hFlush stdout
 
@@ -35,28 +44,31 @@ showAction :: String -> Annex ()
 showAction s = showNote $ s ++ "..."
 
 showProgress :: Annex ()
-showProgress = verbose $ liftIO $ do
+showProgress = handle q $ do
 	putStr "."
 	hFlush stdout
 
 showSideAction :: String -> Annex ()
-showSideAction s = verbose $ liftIO $ putStrLn $ "(" ++ s ++ "...)"
+showSideAction s = handle q $ putStrLn $ "(" ++ s ++ "...)"
 
 showOutput :: Annex ()
-showOutput = verbose $ liftIO $ putStr "\n"
+showOutput = handle q $ putStr "\n"
 
 showLongNote :: String -> Annex ()
-showLongNote s = verbose $ liftIO $ putStr $ '\n' : indent s
+showLongNote s = handle (JSON.note s) $ putStr $ '\n' : indent s
 
 showEndOk :: Annex ()
-showEndOk = verbose $ liftIO $ putStrLn "ok"
+showEndOk = showEndResult True
 
 showEndFail :: Annex ()
-showEndFail = verbose $ liftIO $ putStrLn "failed"
+showEndFail = showEndResult False
 
 showEndResult :: Bool -> Annex ()
-showEndResult True = showEndOk
-showEndResult False = showEndFail
+showEndResult b = handle (JSON.end b) $ putStrLn msg
+	where
+		msg
+			| b = "ok"
+			| otherwise = "failed"
 
 showErr :: (Show a) => a -> Annex ()
 showErr e = liftIO $ do
@@ -65,7 +77,7 @@ showErr e = liftIO $ do
 
 warning :: String -> Annex ()
 warning w = do
-	verbose $ liftIO $ putStr "\n"
+	handle q $ putStr "\n"
 	liftIO $ do
 		hFlush stdout
 		hPutStrLn stderr $ indent w
@@ -85,3 +97,14 @@ setupConsole :: IO ()
 setupConsole = do
 	hSetBinaryMode stdout True
 	hSetBinaryMode stderr True
+
+handle :: IO () -> IO () -> Annex ()
+handle json normal = do
+	output <- Annex.getState Annex.output
+	case output of
+		Annex.NormalOutput -> liftIO normal
+		Annex.QuietOutput -> q
+		Annex.JSONOutput -> liftIO json
+
+q :: Monad m => m ()
+q = return ()
diff --git a/Messages/JSON.hs b/Messages/JSON.hs
new file mode 100644
index 000000000..ee6ea34a3
--- /dev/null
+++ b/Messages/JSON.hs
@@ -0,0 +1,23 @@
+{- git-annex JSON output
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Messages.JSON (
+	start,
+	end,
+	note
+) where
+
+import qualified Utility.JSONStream as Stream
+
+start :: String -> String -> IO ()
+start command file = putStr $ Stream.start [("command", command), ("file", file)]
+
+end :: Bool -> IO ()
+end b = putStr $ Stream.add [("success", b)] ++ Stream.end
+
+note :: String -> IO ()
+note s = putStr $ Stream.add [("note", s)]
diff --git a/Options.hs b/Options.hs
index 768a1c289..e0ca48c01 100644
--- a/Options.hs
+++ b/Options.hs
@@ -30,6 +30,8 @@ commonOptions =
 		"avoid verbose output"
 	, Option ['v'] ["verbose"] (NoArg (setoutput Annex.NormalOutput))
 		"allow verbose output (default)"
+	, Option ['j'] ["json"] (NoArg (setoutput Annex.JSONOutput))
+		"enable JSON output"
 	, Option ['d'] ["debug"] (NoArg (setdebug))
 		"show debug messages"
 	, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs
new file mode 100644
index 000000000..af3766948
--- /dev/null
+++ b/Utility/JSONStream.hs
@@ -0,0 +1,44 @@
+{- Streaming JSON output.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.JSONStream (
+	start,
+	add,
+	end
+) where
+
+import Text.JSON
+
+{- Text.JSON does not support building up a larger JSON document piece by
+   piece as a stream. To support streaming, a hack. The JSObject is converted
+   to a string with its final "}" is left off, allowing it to be added to
+   later. -}
+start :: JSON a => [(String, a)] -> String
+start l
+	| last s == endchar = take (length s - 1)  s
+	| otherwise = bad s
+	where
+		s = encodeStrict $ toJSObject l
+
+add :: JSON a => [(String, a)] -> String
+add l
+	| head s == startchar = ',' : drop 1 s
+	| otherwise = bad s
+	where
+		s = start l
+
+end :: String
+end = [endchar, '\n']
+
+startchar :: Char
+startchar = '{'
+
+endchar :: Char
+endchar = '}'
+
+bad :: String -> a
+bad s = error $ "Text.JSON returned unexpected string: " ++ s
diff --git a/debian/changelog b/debian/changelog
index 4ee0b80f2..ca23ab473 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -6,6 +6,7 @@ git-annex (3.20110820) UNRELEASED; urgency=low
   * init: Make description an optional parameter.
   * unused, status: Sped up by avoiding unnecessary stats of annexed files.
   * unused --remote: Reduced memory use to 1/4th what was used before.
+  * Add --json switch, to produce machine-consumable output.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 23 Aug 2011 13:41:01 -0400
 
diff --git a/debian/control b/debian/control
index 63488dc68..cb5a8212a 100644
--- a/debian/control
+++ b/debian/control
@@ -14,6 +14,7 @@ Build-Depends:
 	libghc-hs3-dev (>= 0.5.6),
 	libghc-testpack-dev [any-i386 any-amd64],
 	libghc-monad-control-dev,
+	libghc-json-dev,
 	ikiwiki,
 	perlmagick,
 	git | git-core,
diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn
index e7ac9adf7..0a484a384 100644
--- a/doc/git-annex.mdwn
+++ b/doc/git-annex.mdwn
@@ -337,12 +337,18 @@ Many git-annex commands will stage changes for later `git commit` by you.
 
 * --quiet
 
-  Avoid the default verbose logging of what is done; only show errors
+  Avoid the default verbose display of what is done; only show errors
   and progress displays.
 
 * --verbose
 
-  Enable verbose logging.
+  Enable verbose display.
+
+* --json
+
+  Rather than the normal output, generate JSON. This is intended to be
+  parsed by programs that use git-annex. Each line of output is a JSON
+  object.
 
 * --debug
 
diff --git a/doc/install.mdwn b/doc/install.mdwn
index ac521da18..cd51b96d2 100644
--- a/doc/install.mdwn
+++ b/doc/install.mdwn
@@ -28,6 +28,7 @@ To build and use git-annex, you will need:
   * [QuickCheck 2](http://hackage.haskell.org/package/QuickCheck)
   * [HTTP](http://hackage.haskell.org/package/HTTP)
   * [hS3](http://hackage.haskell.org/package/hS3) (optional, but recommended)
+  * [json](http://hackage.haskell.org/package/json)
 * Shell commands
   * [git](http://git-scm.com/)
   * [uuid](http://www.ossp.org/pkg/lib/uuid/)