diff options
Diffstat (limited to 'Messages')
| -rw-r--r-- | Messages/Internal.hs | 43 | ||||
| -rw-r--r-- | Messages/JSON.hs | 70 |
2 files changed, 62 insertions, 51 deletions
diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 2c9a461a5..7ea8ee067 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -13,44 +13,39 @@ import Types.Messages import Messages.Concurrent import Messages.JSON -import qualified Data.ByteString.Lazy as B withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a -outputMessage :: JSONChunk -> String -> Annex () -outputMessage = outputMessage' False - -outputMessageFinal :: JSONChunk -> String -> Annex () -outputMessageFinal = outputMessage' True - -outputMessage' :: Bool -> JSONChunk -> String -> Annex () -outputMessage' endmessage json msg = withMessageState $ \s -> case outputType s of +outputMessage :: JSONBuilder -> String -> Annex () +outputMessage jsonbuilder msg = withMessageState $ \s -> case outputType s of NormalOutput | concurrentOutputEnabled s -> concurrentMessage s False msg q | otherwise -> liftIO $ flushed $ putStr msg - JSONOutput _ -> void $ outputJSON json endmessage s + JSONOutput _ -> void $ outputJSON jsonbuilder s QuietOutput -> q -outputJSON :: JSONChunk -> Bool -> MessageState -> Annex Bool -outputJSON json endmessage s = case outputType s of - JSONOutput withprogress - | withprogress || concurrentOutputEnabled s -> do - -- Buffer json fragments until end is reached. - if endmessage - then do - Annex.changeState $ \st -> - st { Annex.output = s { jsonBuffer = none } } - liftIO $ flushed $ emit b - else Annex.changeState $ \st -> - st { Annex.output = s { jsonBuffer = b } } +-- Buffer changes to JSON until end is reached and then emit it. +outputJSON :: JSONBuilder -> MessageState -> Annex Bool +outputJSON jsonbuilder s = case outputType s of + JSONOutput _ + | endjson -> do + Annex.changeState $ \st -> + st { Annex.output = s { jsonBuffer = Nothing } } + maybe noop (liftIO . flushed . emit) json return True | otherwise -> do - liftIO $ flushed $ emit json + Annex.changeState $ \st -> + st { Annex.output = s { jsonBuffer = json } } return True _ -> return False where - b = jsonBuffer s `B.append` json + (json, endjson) = case jsonbuilder i of + Nothing -> (jsonBuffer s, False) + (Just (j, e)) -> (Just j, e) + i = case jsonBuffer s of + Nothing -> Nothing + Just b -> Just (b, False) outputError :: String -> Annex () outputError msg = withMessageState $ \s -> diff --git a/Messages/JSON.hs b/Messages/JSON.hs index e8491c691..6c22d9537 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -5,10 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} module Messages.JSON ( - JSONChunk, + JSONBuilder, + JSONChunk(..), emit, none, start, @@ -27,6 +28,7 @@ import Control.Applicative import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString.Lazy as B +import qualified Data.HashMap.Strict as HM import System.IO import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -34,29 +36,31 @@ import Data.Maybe import Data.Monoid import Prelude -import qualified Utility.JSONStream as Stream import Types.Key import Utility.Metered import Utility.Percentage -type JSONChunk = B.ByteString - -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-} emitLock :: MVar () emitLock = unsafePerformIO $ newMVar () -emit :: JSONChunk -> IO () -emit v = do +emit :: Object -> IO () +emit o = do takeMVar emitLock - B.hPut stdout v + B.hPut stdout (encode o) + putStr "\n" putMVar emitLock () -none :: JSONChunk -none = B.empty +-- Building up a JSON object can be done by first using start, +-- then add and note any number of times, and finally complete. +type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool) + +none :: JSONBuilder +none = id -start :: String -> Maybe FilePath -> Maybe Key -> JSONChunk -start command file key = Stream.start $ Stream.AesonObject o +start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder +start command file key _ = Just (o, False) where Object o = toJSON $ JSONActionItem { itemCommand = Just command @@ -65,24 +69,36 @@ start command file key = Stream.start $ Stream.AesonObject o , itemAdded = Nothing } -end :: Bool -> JSONChunk -end b =Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end +end :: Bool -> JSONBuilder +end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True) +end _ Nothing = Nothing -note :: String -> JSONChunk -note s = add (Stream.JSONChunk [("note", s)]) +note :: String -> JSONBuilder +note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e) +note _ Nothing = Nothing -add :: Stream.JSONChunk a -> JSONChunk -add = Stream.add +data JSONChunk v where + AesonObject :: Object -> JSONChunk Object + JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] -complete :: Stream.JSONChunk a -> JSONChunk -complete v = Stream.start v `B.append` Stream.end - -progress :: B.ByteString -> Integer -> BytesProcessed -> IO () -progress jsonbuffer size bytesprocessed = emit $ B.concat - [ Stream.start $ Stream.AesonObject o - , Stream.addNestedObject "action" jsonbuffer - , Stream.end - ] +add :: JSONChunk v -> JSONBuilder +add v (Just (o, e)) = Just (HM.union o' o, e) + where + Object o' = case v of + AesonObject ao -> Object ao + JSONChunk l -> object (map mkPair l) + mkPair (s, d) = (T.pack s, toJSON d) +add _ Nothing = Nothing + +complete :: JSONChunk v -> JSONBuilder +complete v _ = add v (Just (HM.empty, True)) + +-- Show JSON formatted progress, including the current state of the JSON +-- object for the action being performed. +progress :: Maybe Object -> Integer -> BytesProcessed -> IO () +progress maction size bytesprocessed = emit $ case maction of + Just action -> HM.insert "action" (Object action) o + Nothing -> o where n = fromBytesProcessed bytesprocessed :: Integer Object o = object |