Expect json input separated by STX, fix haskell#43

Author: cocreature

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

@@ -4,19 +4,21 @@
 module Haskell.Ide.Engine.Transport.JsonStdio where
 
 import           Control.Concurrent
+import           Control.Lens (view)
 import           Control.Logging
 import qualified Data.Aeson as A
+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.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 qualified Pipes.Prelude as P hiding (drop,length)
 import           System.IO
 
 -- TODO: Can pass in a handle, then it is general
@@ -25,19 +27,27 @@ jsonStdioTransport cin = do
   cout <- newChan :: IO (Chan ChannelResponse)
   hSetBuffering stdout NoBuffering
   let
+    processParse cid r stream = do
+      writeChan cin (wireToChannel cout cid r)
+      rsp <- readChan cout
+      BL.putStr $ A.encode (channelToWire rsp)
+      loop (cid + 1) (P.drop (1::Int) stream)
     loop cid stream = do
       debug "jsonStdioTransport:calling go"
-      (req,stream') <- runStateT decodeMsg stream
+      let splitStream = view (P.break (== fromIntegral (ord '\STX'))) stream
+      (req,res) <- runStateT decodeMsg splitStream
       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'
+          nextStreamOrError <- next res
+          case nextStreamOrError of
+            Left nextStream -> processParse cid r nextStream
+            Right (a,restConsumer) -> do (restLength,nextStream) <- P.fold' (\n bs -> n + fromIntegral (B.length bs)) 0 id restConsumer
+                                         if (B.length a + restLength > 0) then
+                                           putStr $ show (HieError (A.String $ "Unexpected input before separator"))
+                                         else processParse cid r nextStream
         Nothing -> do
           -- exit the loop
           putStr $ show (HieError (A.String $ T.pack $ "Got Nothing"))