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           Control.Exception
  14 import           Control.Lens
  15 import qualified Data.ByteString.Lazy.Char8    as B
  16 import           Data.Maybe
  17 import           System.IO
  18 import           System.IO.Error
  19 import           Language.Haskell.LSP.Types
  20 import           Language.Haskell.LSP.Types.Lens
  21 import           Language.Haskell.LSP.Test.Exceptions
  22 import qualified Data.HashMap.Strict           as HM
  23
  24 import Data.IxMap
  25 import Data.Kind
  26 import Data.Maybe
  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     _ -> acc
  82
  83 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
  84 decodeFromServerMsg reqMap bytes =  fst $ fromJust $ parseMaybe p obj
  85   where obj = fromJust $ decode bytes :: Value
  86         p = parseServerMessage (\i -> (,()) <$> lookupIxMap i reqMap)
  87         {-
  88         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
  89         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
  90         CustomServerMethod _
  91             | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
  92             | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
  93             | otherwise -> NotCustomServer $ fromJust $ decode bytes
  94
  95       Error e -> error e
  96       -}