src/Language/LSP/Test/Decoding.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TupleSections #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE KindSignatures #-}
   5 {-# LANGUAGE TypeInType #-}
   6 module Language.LSP.Test.Decoding where
   7
   8 import           Prelude                 hiding ( id )
   9 import           Data.Aeson
  10 import           Data.Aeson.Types
  11 import           Data.Foldable
  12 import           Data.Functor.Product
  13 import           Data.Functor.Const
  14 import           Control.Exception
  15 import           Control.Lens
  16 import qualified Data.ByteString.Lazy.Char8    as B
  17 import           Data.Maybe
  18 import           System.IO
  19 import           System.IO.Error
  20 import           Language.LSP.Types
  21 import           Language.LSP.Types.Lens
  22 import           Language.LSP.Test.Exceptions
  23
  24 import Data.IxMap
  25 import Data.Kind
  26
  27 getAllMessages :: Handle -> IO [B.ByteString]
  28 getAllMessages h = do
  29   done <- hIsEOF h
  30   if done
  31     then return []
  32     else do
  33       msg <- getNextMessage h
  34
  35       (msg :) <$> getAllMessages h
  36
  37 -- | Fetches the next message bytes based on
  38 -- the Content-Length header
  39 getNextMessage :: Handle -> IO B.ByteString
  40 getNextMessage h = do
  41   headers <- getHeaders h
  42   case read . init <$> lookup "Content-Length" headers of
  43     Nothing   -> throw NoContentLengthHeader
  44     Just size -> B.hGet h size
  45
  46 addHeader :: B.ByteString -> B.ByteString
  47 addHeader content = B.concat
  48   [ "Content-Length: "
  49   , B.pack $ show $ B.length content
  50   , "\r\n"
  51   , "\r\n"
  52   , content
  53   ]
  54
  55 getHeaders :: Handle -> IO [(String, String)]
  56 getHeaders h = do
  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
  60   where eofHandler e
  61           | isEOFError e = throw UnexpectedServerTermination
  62           | otherwise = throw e
  63
  64 type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )
  65
  66 newRequestMap :: RequestMap
  67 newRequestMap = emptyIxMap
  68
  69 updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
  70 updateRequestMap reqMap id method = insertIxMap id method reqMap
  71
  72 getRequestMap :: [FromClientMessage] -> RequestMap
  73 getRequestMap = foldl' helper emptyIxMap
  74  where
  75   helper :: RequestMap -> FromClientMessage -> RequestMap
  76   helper acc msg = case msg of
  77     FromClientMess m mess -> case splitClientMethod m of
  78       IsClientNot -> acc
  79       IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
  80       IsClientEither -> case mess of
  81         NotMess _ -> acc
  82         ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
  83     _ -> acc
  84
  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
  90             in case mm of
  91               Nothing -> Nothing
  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)
  95         {-
  96         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
  97         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
  98         CustomServerMethod _
  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
 102
 103       Error e -> error e
 104       -}