Use attoparsec to parse message headers incrementally

Previously, we were repeatedly reading one character, appending it to
the end and trying to parse until parsec returned a result. This is
needlessly wasteful and while it’s probably not a bottleneck, I think
the incremental parsing with attoparsec is also easier to understand
so it’s a win both in readability and performance.

haskell-lsp.cabal

@@ -38,6 +38,7 @@ library
   build-depends:       base >=4.9 && <4.13
                      , async
                      , aeson >=1.0.0.0
+                     , attoparsec
                      , bytestring
                      , containers
                      , directory
@@ -49,7 +50,6 @@ library
                      , lens >= 4.15.2
                      , mtl
                      , network-uri
-                     , parsec
                      , rope-utf16-splay >= 0.3.1.0
                      , sorted-list == 0.2.1.*
                      , stm
@@ -78,7 +78,6 @@ executable lsp-hello
                      , lens >= 4.15.2
                      , mtl
                      , network-uri
-                     , parsec
                      , rope-utf16-splay >= 0.2
                      , stm
                      , text

src/Language/Haskell/LSP/Control.hs

@@ -17,6 +17,10 @@ import           Control.Concurrent.STM.TVar
 import           Control.Monad
 import           Control.Monad.STM
 import qualified Data.Aeson as J
+import qualified Data.Attoparsec.ByteString as Attoparsec
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString as BS
+import Data.ByteString.Builder.Extra (defaultChunkSize)
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.Time.Clock
@@ -30,7 +34,6 @@ import           Language.Haskell.LSP.Messages
 import           Language.Haskell.LSP.Utility
 import           System.IO
 import           System.FilePath
-import           Text.Parsec
 
 -- ---------------------------------------------------------------------
 
@@ -94,40 +97,27 @@ ioLoop :: (Show c) => Handle
                    -> Core.InitializeCallback c
                    -> TVar (Core.LanguageContextData c)
                    -> IO ()
-ioLoop hin dispatcherProc tvarDat = go BSL.empty
+ioLoop hin dispatcherProc tvarDat = do
+  go (parse parser "")
   where
-    go :: BSL.ByteString -> IO ()
-    go buf = do
-      c <- BSL.hGet hin 1
-
-      if c == BSL.empty
-        then do
-          logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"
-          return ()
-        else do
-          -- logs $ "ioLoop: got" ++ show c
-          let newBuf = BSL.append buf c
-          case readContentLength (lbs2str newBuf) of
-            Left _ -> go newBuf
-            Right len -> do
-              cnt <- BSL.hGet hin len
-
-              if cnt == BSL.empty
-                then do
-                  logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"
-                  return ()
-                else do
-                  logm $ B.pack "---> " <> cnt
-                  Core.handleMessage dispatcherProc tvarDat newBuf cnt
-                  ioLoop hin dispatcherProc tvarDat
-      where
-        readContentLength :: String -> Either ParseError Int
-        readContentLength = parse parser "readContentLength"
-
-        parser = do
-          _ <- string "Content-Length: "
-          len <- manyTill digit (string _TWO_CRLF)
-          return . read $ len
+    go :: Result BS.ByteString -> IO ()
+    go (Fail _ ctxs err) = logm $ B.pack
+      "\nhaskell-lsp: Failed to parse message header:\n" <> B.intercalate " > " (map str2lbs ctxs) <> ": " <>
+      str2lbs err <> "\n exiting 1 ...\n"
+    go (Partial c) = do
+      bs <- BS.hGetSome hin defaultChunkSize
+      if BS.null bs
+        then logm $ B.pack "\nhaskell-lsp:Got EOF, exiting 1 ...\n"
+        else go (c bs)
+    go (Done remainder msg) = do
+      logm $ B.pack "---> " <> BSL.fromStrict msg
+      Core.handleMessage dispatcherProc tvarDat (BSL.fromStrict msg)
+      go (parse parser remainder)
+    parser = do
+      _ <- string "Content-Length: "
+      len <- decimal
+      _ <- string _TWO_CRLF
+      Attoparsec.take len
 
 -- ---------------------------------------------------------------------
 
@@ -144,7 +134,7 @@ sendServer msgChan clientH captureFp =
 
     let out = BSL.concat
                  [ str2lbs $ "Content-Length: " ++ show (BSL.length str)
-                 , str2lbs _TWO_CRLF
+                 , BSL.fromStrict _TWO_CRLF
                  , str ]
 
     BSL.hPut clientH out
@@ -156,7 +146,7 @@ sendServer msgChan clientH captureFp =
 -- |
 --
 --
-_TWO_CRLF :: String
+_TWO_CRLF :: BS.ByteString
 _TWO_CRLF = "\r\n\r\n"
 
 

src/Language/Haskell/LSP/Core.hs

@@ -497,8 +497,8 @@ defaultProgressData = ProgressData 0 Map.empty
 -- ---------------------------------------------------------------------
 
 handleMessage :: (Show c) => InitializeCallback c
-              -> TVar (LanguageContextData c) -> BSL.ByteString -> BSL.ByteString -> IO ()
-handleMessage dispatcherProc tvarDat contLenStr jsonStr = do
+              -> TVar (LanguageContextData c) -> BSL.ByteString -> IO ()
+handleMessage dispatcherProc tvarDat jsonStr = do
   {-
   Message Types we must handle are the following
 
@@ -510,7 +510,7 @@ handleMessage dispatcherProc tvarDat contLenStr jsonStr = do
 
   case J.eitherDecode jsonStr :: Either String J.Object of
     Left  err -> do
-      let msg =  T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str contLenStr, lbs2str jsonStr, show err]
+      let msg =  T.pack $ unwords [ "haskell-lsp:incoming message parse error.", lbs2str jsonStr, show err]
               ++ L.intercalate "\n" ("" : "" : _ERR_MSG_URL)
               ++ "\n"
       sendErrorLog tvarDat msg
@@ -522,7 +522,7 @@ handleMessage dispatcherProc tvarDat contLenStr jsonStr = do
                                    J.Success m -> handle (J.Object o) m
                                    J.Error _ -> do
                                      let msg = T.pack $ unwords ["haskell-lsp:unknown message received:method='"
-                                                                 ++ T.unpack s ++ "',", lbs2str contLenStr, lbs2str jsonStr]
+                                                                 ++ T.unpack s ++ "',", lbs2str jsonStr]
                                      sendErrorLog tvarDat msg
         Just oops -> logs $ "haskell-lsp:got strange method param, ignoring:" ++ show oops
         Nothing -> do

test/WorkspaceFoldersSpec.hs

@@ -5,7 +5,6 @@ module WorkspaceFoldersSpec where
 import Control.Concurrent.MVar
 import Control.Concurrent.STM
 import Data.Aeson
-import qualified Data.ByteString.Lazy.Char8 as BSL
 import Data.Default
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.Types
@@ -28,8 +27,7 @@ spec = describe "workspace folders" $
 
     let putMsg msg =
           let jsonStr = encode msg
-              clStr = BSL.pack $ "Content-Length: " ++ show (BSL.length jsonStr)
-            in handleMessage initCb tvarCtx clStr jsonStr
+            in handleMessage initCb tvarCtx jsonStr
 
     let starterWorkspaces = List [wf0]
         initParams = InitializeParams