src/Language/LSP/Test/Decoding.hs

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