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