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