diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal index ba882fd91..14eb950bb 100644 --- a/haskell-lsp.cabal +++ b/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 diff --git a/src/Language/Haskell/LSP/Control.hs b/src/Language/Haskell/LSP/Control.hs index 9c38e8e17..2cf5c2dba 100644 --- a/src/Language/Haskell/LSP/Control.hs +++ b/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" diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs index 9938efa0e..98a53549e 100644 --- a/src/Language/Haskell/LSP/Core.hs +++ b/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 diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs index 9f176d6ef..8c62384d7 100644 --- a/test/WorkspaceFoldersSpec.hs +++ b/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