src/Language/Haskell/LSP/Test/Decoding.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Haskell.LSP.Test.Decoding where
   3
   4 import           Prelude                 hiding ( id )
   5 import           Data.Aeson
   6 import           Control.Lens
   7 import qualified Data.ByteString.Lazy.Char8    as B
   8 import           Data.Maybe
   9 import           System.IO
  10 import           Language.Haskell.LSP.Types
  11                                          hiding ( error )
  12 import           Language.Haskell.LSP.Messages
  13 import qualified Data.HashMap.Strict           as HM
  14
  15 getAllMessages :: Handle -> IO [B.ByteString]
  16 getAllMessages h = do
  17   done <- hIsEOF h
  18   if done
  19     then return []
  20     else do
  21       msg <- getNextMessage h
  22
  23       (msg :) <$> getAllMessages h
  24
  25 -- | Fetches the next message bytes based on
  26 -- the Content-Length header
  27 getNextMessage :: Handle -> IO B.ByteString
  28 getNextMessage h = do
  29   headers <- getHeaders h
  30   case read . init <$> lookup "Content-Length" headers of
  31     Nothing   -> error "Couldn't read Content-Length header"
  32     Just size -> B.hGet h size
  33
  34 addHeader :: B.ByteString -> B.ByteString
  35 addHeader content = B.concat
  36   [ "Content-Length: "
  37   , B.pack $ show $ B.length content
  38   , "\r\n"
  39   , "\r\n"
  40   , content
  41   ]
  42
  43 getHeaders :: Handle -> IO [(String, String)]
  44 getHeaders h = do
  45   l <- hGetLine h
  46   let (name, val) = span (/= ':') l
  47   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
  48
  49 type RequestMap = HM.HashMap LspId ClientMethod
  50
  51 newRequestMap :: RequestMap
  52 newRequestMap = HM.empty
  53
  54 updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
  55 updateRequestMap reqMap id method = HM.insert id method reqMap
  56
  57 getRequestMap :: [FromClientMessage] -> RequestMap
  58 getRequestMap = foldl helper HM.empty
  59  where
  60   helper acc msg = case msg of
  61     (ReqInitialize val) -> insert val acc
  62     (ReqShutdown val) -> insert val acc
  63     (ReqHover val) -> insert val acc
  64     (ReqCompletion val) -> insert val acc
  65     (ReqCompletionItemResolve val) -> insert val acc
  66     (ReqSignatureHelp val) -> insert val acc
  67     (ReqDefinition val) -> insert val acc
  68     (ReqFindReferences val) -> insert val acc
  69     (ReqDocumentHighlights val) -> insert val acc
  70     (ReqDocumentSymbols val) -> insert val acc
  71     (ReqWorkspaceSymbols val) -> insert val acc
  72     (ReqCodeAction val) -> insert val acc
  73     (ReqCodeLens val) -> insert val acc
  74     (ReqCodeLensResolve val) -> insert val acc
  75     (ReqDocumentFormatting val) -> insert val acc
  76     (ReqDocumentRangeFormatting val) -> insert val acc
  77     (ReqDocumentOnTypeFormatting val) -> insert val acc
  78     (ReqRename val) -> insert val acc
  79     (ReqExecuteCommand val) -> insert val acc
  80     (ReqDocumentLink val) -> insert val acc
  81     (ReqDocumentLinkResolve val) -> insert val acc
  82     (ReqWillSaveWaitUntil val) -> insert val acc
  83     _ -> acc
  84   insert m = HM.insert (m ^. id) (m ^. method)
  85
  86 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
  87 matchResponseMsgType req bytes = case req of
  88   Initialize                    -> RspInitialize $ fromJust $ decode bytes
  89   Shutdown                      -> RspShutdown $ fromJust $ decode bytes
  90   TextDocumentHover             -> RspHover $ fromJust $ decode bytes
  91   TextDocumentCompletion        -> RspCompletion $ fromJust $ decode bytes
  92   CompletionItemResolve         -> RspCompletionItemResolve $ fromJust $ decode bytes
  93   TextDocumentSignatureHelp     -> RspSignatureHelp $ fromJust $ decode bytes
  94   TextDocumentDefinition        -> RspDefinition $ fromJust $ decode bytes
  95   TextDocumentReferences        -> RspFindReferences $ fromJust $ decode bytes
  96   TextDocumentDocumentHighlight -> RspDocumentHighlights $ fromJust $ decode bytes
  97   TextDocumentDocumentSymbol    -> RspDocumentSymbols $ fromJust $ decode bytes
  98   WorkspaceSymbol               -> RspWorkspaceSymbols $ fromJust $ decode bytes
  99   TextDocumentCodeAction        -> RspCodeAction $ fromJust $ decode bytes
 100   TextDocumentCodeLens          -> RspCodeLens $ fromJust $ decode bytes
 101   CodeLensResolve               -> RspCodeLensResolve $ fromJust $ decode bytes
 102   TextDocumentFormatting        -> RspDocumentFormatting $ fromJust $ decode bytes
 103   TextDocumentRangeFormatting   -> RspDocumentRangeFormatting $ fromJust $ decode bytes
 104   TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting $ fromJust $ decode bytes
 105   TextDocumentRename            -> RspRename $ fromJust $ decode bytes
 106   WorkspaceExecuteCommand       -> RspExecuteCommand $ fromJust $ decode bytes
 107   TextDocumentDocumentLink      -> RspDocumentLink $ fromJust $ decode bytes
 108   DocumentLinkResolve           -> RspDocumentLinkResolve $ fromJust $ decode bytes
 109   TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil $ fromJust $ decode bytes
 110   x                             -> error $ "Not a request: " ++ show x
 111
 112 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
 113 decodeFromServerMsg reqMap bytes =
 114   case HM.lookup "method" (fromJust $ decode bytes :: Object) of
 115     Just methodStr -> case fromJSON methodStr of
 116       Success method -> case method of
 117         -- We can work out the type of the message
 118         TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
 119         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
 120         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
 121         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
 122         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
 123         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
 124         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
 125         ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes
 126         WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
 127
 128       Error e -> error e
 129
 130     Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
 131       Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
 132         Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
 133         Nothing  -> error "Couldn't match up response with request"
 134       Nothing -> error "Couldn't decode message"