1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE TupleSections #-}
4 {-# LANGUAGE KindSignatures #-}
5 {-# LANGUAGE TypeInType #-}
6 module Language.LSP.Test.Decoding where
8 import Prelude hiding ( id )
10 import Data.Aeson.Types
12 import Data.Functor.Product
13 import Data.Functor.Const
14 import Control.Exception
16 import qualified Data.ByteString.Lazy.Char8 as B
19 import System.IO.Error
20 import Language.LSP.Types
21 import Language.LSP.Types.Lens
22 import Language.LSP.Test.Exceptions
27 getAllMessages :: Handle -> IO [B.ByteString]
33 msg <- getNextMessage h
35 (msg :) <$> getAllMessages h
37 -- | Fetches the next message bytes based on
38 -- the Content-Length header
39 getNextMessage :: Handle -> IO B.ByteString
41 headers <- getHeaders h
42 case read . init <$> lookup "Content-Length" headers of
43 Nothing -> throw NoContentLengthHeader
44 Just size -> B.hGet h size
46 addHeader :: B.ByteString -> B.ByteString
47 addHeader content = B.concat
49 , B.pack $ show $ B.length content
55 getHeaders :: Handle -> IO [(String, String)]
57 l <- catch (hGetLine h) eofHandler
58 let (name, val) = span (/= ':') l
59 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
61 | isEOFError e = throw UnexpectedServerTermination
64 type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )
66 newRequestMap :: RequestMap
67 newRequestMap = emptyIxMap
69 updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
70 updateRequestMap reqMap id method = insertIxMap id method reqMap
72 getRequestMap :: [FromClientMessage] -> RequestMap
73 getRequestMap = foldl' helper emptyIxMap
75 helper :: RequestMap -> FromClientMessage -> RequestMap
76 helper acc msg = case msg of
77 FromClientMess m mess -> case splitClientMethod m of
79 IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
80 IsClientEither -> case mess of
82 ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
85 decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
86 decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj
87 where obj = fromJust $ decode bytes :: Value
88 p = parseServerMessage $ \lid ->
89 let (mm, newMap) = pickFromIxMap lid reqMap
92 Just m -> Just $ (m, Pair m (Const newMap))
93 unP (FromServerMess m msg) = (reqMap, FromServerMess m msg)
94 unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)
96 WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"
97 WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"
99 | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
100 | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
101 | otherwise -> NotCustomServer $ fromJust $ decode bytes