Text.Pandoc.Server: return object if JSON is accepted.

Previously we just returned a JSON-encoded string.

Now we return something like:

```
{
    "output": "<p>hello</p>"
    "base64": false,
    "messages": [
        {
            "message": "Not rendering RawInline (Format \"tex\") \"\\\\noe\"",
            "verbosity": "INFO"
        }
    ],
}
```

This is a change in the pandoc-server JSON API.

1 files changed, 56 insertions, 12 deletions

diff --git a/src/Text/Pandoc/Server.hs b/src/Text/Pandoc/Server.hs
index 7dfde3aa3..3d6829d94 100644
--- a/src/Text/Pandoc/Server.hs
+++ b/src/Text/Pandoc/Server.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE TypeOperators   #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -41,6 +42,7 @@ import Text.Pandoc.App.Opt ( IpynbOutput (..), Opt(..), defaultOpts )
 import Text.Pandoc.Builder (setMeta)
 import Text.Pandoc.SelfContained (makeSelfContained)
 import System.Exit
+import GHC.Generics (Generic)
 
 data ServerOpts =
   ServerOpts
@@ -141,16 +143,36 @@ instance FromJSON Params where
      <*> o .:? "files"
      <*> o .:? "citeproc"
 
+data Message =
+  Message
+  { verbosity :: Verbosity
+  , message   :: Text }
+  deriving (Generic, Show)
+
+instance ToJSON Message where
+ toEncoding = genericToEncoding defaultOptions
+
+data Output =
+  Output
+  { output    :: Text
+  , base64    :: Bool
+  , messages  :: [Message] }
+  deriving (Generic, Show)
+
+instance ToJSON Output where
+ toEncoding = genericToEncoding defaultOptions
 
 -- This is the API.  The "/convert" endpoint takes a request body
 -- consisting of a JSON-encoded Params structure and responds to
 -- Get requests with either plain text or JSON, depending on the
 -- Accept header.
 type API =
-  ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text
+  ReqBody '[JSON] Params :> Post '[PlainText] Text
   :<|>
   ReqBody '[JSON] Params :> Post '[OctetStream] BS.ByteString
   :<|>
+  ReqBody '[JSON] Params :> Post '[JSON] Output
+  :<|>
   "batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Text]
   :<|>
   "babelmark" :> QueryParam' '[Required] "text" Text :> QueryParam "from" Text :> QueryParam "to" Text :> QueryFlag "standalone" :> Get '[JSON] Value
@@ -166,6 +188,7 @@ api = Proxy
 server :: Server API
 server = convert
     :<|> convertBytes
+    :<|> convertJSON
     :<|> mapM convert
     :<|> babelmark  -- for babelmark which expects {"html": "", "version": ""}
     :<|> pure pandocVersion
@@ -186,12 +209,32 @@ server = convert
   --    handleErr =<< liftIO (runIO (convert' params))
   -- will allow the IO operations.
   convert params = handleErr $
-    runPure (convert' id (encodeBase64 . BL.toStrict) params)
+    runPure (convert' return (return . encodeBase64 . BL.toStrict) params)
 
   convertBytes params = handleErr $
-    runPure (convert' UTF8.fromText BL.toStrict params)
-
-  convert' :: (Text -> a) -> (BL.ByteString -> a) -> Params -> PandocPure a
+    runPure (convert' (return . UTF8.fromText) (return . BL.toStrict) params)
+
+  convertJSON params = handleErr $
+    runPure
+      (convert'
+        (\t -> do
+            msgs <- getLog
+            return Output{ output = t
+                         , base64 = False
+                         , messages = map toMessage msgs })
+        (\bs -> do
+            msgs <- getLog
+            return Output{ output = encodeBase64 (BL.toStrict bs)
+                         , base64 = True
+                         , messages = map toMessage msgs })
+        params)
+
+  toMessage m = Message { verbosity = messageVerbosity m
+                        , message = showLogMessage m }
+
+  convert' :: (Text -> PandocPure a)
+           -> (BL.ByteString -> PandocPure a)
+           -> Params -> PandocPure a
   convert' textHandler bsHandler params = do
     curtime <- getCurrentTime
     -- put files params in ersatz file system
@@ -281,14 +324,15 @@ server = convert
                   case eitherbs of
                     Left errt -> throwError $ PandocSomeError errt
                     Right bs -> r readeropts $ BL.fromStrict bs
-    let writer = case writerSpec of
+    let writer d = case writerSpec of
                 TextWriter w ->
-                  fmap textHandler .
-                  (\d -> w writeropts d >>=
-                         if optEmbedResources opts && htmlFormat (optTo opts)
-                            then makeSelfContained
-                            else return)
-                ByteStringWriter w -> fmap bsHandler . w writeropts
+                  w writeropts d >>=
+                    (if optEmbedResources opts && htmlFormat (optTo opts)
+                        then makeSelfContained
+                        else return) >>=
+                    textHandler
+                ByteStringWriter w ->
+                  w writeropts d >>= bsHandler
 
     let transforms :: Pandoc -> Pandoc
         transforms = (case optShiftHeadingLevelBy opts of