Expect json input separated by STX, fix #43

Author: cocreature

haskell-ide-engine.cabal

@@ -25,10 +25,10 @@ library
                        Haskell.Ide.Engine.Transport.JsonStdio
                        Haskell.Ide.Engine.Types
   other-modules:       Paths_haskell_ide_engine
-  build-depends:       base >= 4.7 && < 5
-                     , Cabal >= 1.22
+  build-depends:       Cabal >= 1.22
                      , aeson
                      , attoparsec
+                     , base >= 4.7 && < 5
                      , bytestring
                      , containers
                      , directory
@@ -46,6 +46,7 @@ library
                      , optparse-simple >= 0.0.3
                      , pipes
                      , pipes-aeson
+                     , pipes-attoparsec >= 0.5
                      , pipes-bytestring
                      , pipes-parse
                      , servant-server

src/Haskell/Ide/Engine/Transport/JsonStdio.hs

@@ -1,53 +1,106 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
 -- |Provide a protocol adapter/transport for JSON over stdio
 
 module Haskell.Ide.Engine.Transport.JsonStdio where
 
 import           Control.Concurrent
+import           Control.Lens (view)
 import           Control.Logging
+import           Control.Monad.State.Strict
 import qualified Data.Aeson as A
+import qualified Data.Attoparsec.ByteString as AB
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import           Data.Char
 import qualified Data.Map as Map
+import qualified Data.Text as T
 import           Haskell.Ide.Engine.PluginDescriptor
 import           Haskell.Ide.Engine.Types
-import           Pipes
-import qualified Pipes.Aeson as P
-import qualified Pipes.ByteString as P
+import qualified Pipes as P
+import qualified Pipes.Aeson as PAe
+import qualified Pipes.Attoparsec as PA
+import qualified Pipes.ByteString as PB
 import qualified Pipes.Prelude as P
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.Text as T
-import           Pipes.Parse
 import           System.IO
 
 -- TODO: Can pass in a handle, then it is general
 jsonStdioTransport :: Chan ChannelRequest -> IO ()
 jsonStdioTransport cin = do
   cout <- newChan :: IO (Chan ChannelResponse)
   hSetBuffering stdout NoBuffering
-  let
-    loop cid stream = do
-      debug "jsonStdioTransport:calling go"
-      (req,stream') <- runStateT decodeMsg stream
-      debug $ T.pack $ "jsonStdioTransport:got:" ++ show req
-      case req of
-        Just (Left err) -> do
-          putStr $ show (HieError (A.String $ T.pack $ show err))
-          loop (cid + 1) stream'
-        Just (Right r) -> do
-          writeChan cin (wireToChannel cout cid r)
-          rsp <- readChan cout
-          BL.putStr $ A.encode (channelToWire rsp)
-          loop (cid + 1) stream'
-        Nothing -> do
-          -- exit the loop
-          putStr $ show (HieError (A.String $ T.pack $ "Got Nothing"))
-  loop 1 P.stdin
-
-decodeMsg :: (Monad m) => Parser B.ByteString m (Maybe (Either P.DecodingError WireRequest))
-decodeMsg = P.decode
+  P.runEffect (parseFrames PB.stdin P.>-> parseToJsonPipe cin cout 1 P.>-> jsonConsumer)
+
+parseToJsonPipe
+  :: Chan ChannelRequest
+  -> Chan ChannelResponse
+  -> Int
+  -> P.Pipe (Either PAe.DecodingError WireRequest) A.Value IO ()
+parseToJsonPipe cin cout cid =
+  do parseRes <- P.await
+     case parseRes of
+       Left decodeErr ->
+         do let rsp =
+                  CResp "" cid $
+                  IdeResponseError
+                    (A.toJSON (HieError (A.String $ T.pack $ show decodeErr)))
+            liftIO $ debug $
+              T.pack $ "jsonStdioTransport:parse error:" ++ show decodeErr
+            P.yield $ A.toJSON $ channelToWire rsp
+       Right req ->
+         do liftIO $ writeChan cin (wireToChannel cout cid req)
+            rsp <- liftIO $ readChan cout
+            P.yield $ A.toJSON $ channelToWire rsp
+     parseToJsonPipe cin
+                     cout
+                     (cid + 1)
+
+jsonConsumer :: P.Consumer A.Value IO ()
+jsonConsumer =
+  do val <- P.await
+     liftIO $ BL.putStr (A.encode val)
+     liftIO $ BL.putStr (BL.singleton $ fromIntegral (ord '\STX'))
+     jsonConsumer
+
+parseFrames
+  :: forall m
+   . Monad m
+  => P.Producer B.ByteString m ()
+  -> P.Producer (Either PAe.DecodingError WireRequest) m ()
+parseFrames prod0 = do
+  -- if there are no more bytes, we just return ()
+  (isEmpty, prod1) <- lift $ runStateT PB.isEndOfBytes prod0
+  if isEmpty then return () else go prod1
+  where
+    terminatedJSON :: AB.Parser A.Value
+    terminatedJSON = A.json' <* AB.endOfInput
+    -- endOfInput: we want to be sure that the given
+    -- parser consumes the entirety of the given input
+    go :: P.Producer B.ByteString m ()
+       -> P.Producer (Either PAe.DecodingError WireRequest) m ()
+    go prod = do
+       let splitProd :: P.Producer B.ByteString m (P.Producer B.ByteString m ())
+           splitProd = view (PB.break (== fromIntegral (ord '\STX'))) prod
+       (maybeRet, leftoverProd) <- lift $ runStateT (PA.parse terminatedJSON) splitProd
+       case maybeRet of
+         Nothing -> return ()
+         Just ret -> do
+           let wrappedRet :: Either PAe.DecodingError WireRequest
+               wrappedRet = case ret of
+                              Left parseErr -> Left $ PAe.AttoparsecError parseErr
+                              Right a -> case A.fromJSON a of
+                                           A.Error err -> Left $ PAe.FromJSONError err
+                                           A.Success wireReq -> Right wireReq
+
+           P.yield wrappedRet
+           -- prod3 is guaranteed to be empty by the use of A8.endOfInput in ap1
+           newProd <- lift $ P.runEffect (leftoverProd P.>-> P.drain)
+           -- recur into parseLines to parse the next line, drop the leading '\n'
+           parseFrames (PB.drop (1::Int) newProd)
 
 -- to help with type inference
-printTest :: (MonadIO m) => Consumer' [Int] m r
+printTest :: (MonadIO m) => P.Consumer' [Int] m r
 printTest = P.print
 
 -- ---------------------------------------------------------------------