Send logs to client as JSON

commercialhaskell · Jul 24, 2015 · 7c81675 · 7c81675
1 parent 30ca356
commit 7c81675
Show file tree

Hide file tree

Showing 4 changed files with 18 additions and 13 deletions.
diff --git a/stack-ide-api/src/Stack/Ide/JsonAPI.hs b/stack-ide-api/src/Stack/Ide/JsonAPI.hs
@@ -113,6 +113,7 @@ data Response =
   | ResponseProcessDone RunResult
   | ResponseNoProcessError
   -- Misc
+  | ResponseLog Text
   | ResponseInvalidRequest String
   | ResponseFatalError String
   | ResponseShutdownSession

diff --git a/stack-ide/src/Stack/Ide/CmdLine.hs b/stack-ide/src/Stack/Ide/CmdLine.hs
@@ -49,7 +49,7 @@ parseOptions :: Parser Options
 parseOptions = Options
   <$> parseInitParams
   <*> parseConfig
-  <*> switch (long "verbose" <> short 'v' <> help "Send log messages to stderr")
+  <*> switch (long "verbose" <> short 'v' <> help "Send log messages to client")
 
 {-------------------------------------------------------------------------------
   Parsers for ide-backend types

diff --git a/stack-ide/src/main/Main.hs b/stack-ide/src/main/Main.hs
@@ -1,19 +1,22 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Main where
 
 import Control.Monad (when)
-import Control.Monad.Logger (runStderrLoggingT, LoggingT(..))
+import Control.Monad.Logger (defaultLogStr, LoggingT(..))
 import Data.Aeson
 import Data.Aeson.Parser
 import Data.Aeson.Types
-import Data.ByteString.Lazy.Char8 (toStrict)
 import Data.ByteString.Char8 (hPutStrLn)
+import Data.ByteString.Lazy.Char8 (toStrict)
+import Data.Text.Encoding (decodeUtf8)
 import Stack.Ide
 import Stack.Ide.CmdLine
-import Stack.Ide.JsonAPI ()
+import Stack.Ide.JsonAPI (Response(ResponseLog))
 import Stack.Ide.Util.ValueStream (newStream, nextInStream)
 import System.IO (stdin, stdout, stderr, hSetBuffering, BufferMode(..))
+import System.Log.FastLogger (fromLogStr)
 
 main :: IO ()
 main = do
@@ -29,14 +32,13 @@ main = do
   -- encounter an exception in the input 'Response' value.  In these
   -- cases, we can end up writing a 'ResponseFatalError' in the middle
   -- of a partially serialized 'Response.
-  let clientIO = ClientIO
-        { sendResponse = hPutStrLn stdout . toStrict . encode . toJSON
-        , receiveRequest = fmap fromJSON $ nextInStream input
-        , logMessage = \loc source level str ->
-            when (optVerbose opts) $
-              runStderrLoggingT $ LoggingT $ \func -> func loc source level str
-        }
-        where fromJSON = parseEither parseJSON
+  let sendResponse = hPutStrLn stdout . toStrict . encode . toJSON
+      receiveRequest = fmap (parseEither parseJSON) $ nextInStream input
+      -- Ideally this wouldn't roundtrip through Utf8 encoding, but ohwell.
+      logMessage loc source level str =
+        when (optVerbose opts) $
+          sendResponse $ ResponseLog $ decodeUtf8 $ fromLogStr $ defaultLogStr loc source level str
+      clientIO = ClientIO {..}
 
   -- Disable buffering for interactive piping
   mapM_ (flip hSetBuffering NoBuffering) [stdout, stderr]

diff --git a/stack-ide/stack-ide.cabal b/stack-ide/stack-ide.cabal
@@ -43,8 +43,10 @@ executable stack-ide
   build-depends:       base >= 4.5  && < 5,
                        aeson,
                        bytestring,
+                       fast-logger,
                        monad-logger,
                        stack-ide,
-                       stack-ide-api
+                       stack-ide-api,
+                       text
   default-language:    Haskell2010
   ghc-options:         -Wall