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 import           Language.Haskell.LSP.Messages
  16 import           Language.Haskell.LSP.Test.Exceptions
  17 import qualified Data.HashMap.Strict           as HM
  18
  19 getAllMessages :: Handle -> IO [B.ByteString]
  20 getAllMessages h = do
  21   done <- hIsEOF h
  22   if done
  23     then return []
  24     else do
  25       msg <- getNextMessage h
  26
  27       (msg :) <$> getAllMessages h
  28
  29 -- | Fetches the next message bytes based on
  30 -- the Content-Length header
  31 getNextMessage :: Handle -> IO B.ByteString
  32 getNextMessage h = do
  33   headers <- getHeaders h
  34   case read . init <$> lookup "Content-Length" headers of
  35     Nothing   -> throw NoContentLengthHeader
  36     Just size -> B.hGet h size
  37
  38 addHeader :: B.ByteString -> B.ByteString
  39 addHeader content = B.concat
  40   [ "Content-Length: "
  41   , B.pack $ show $ B.length content
  42   , "\r\n"
  43   , "\r\n"
  44   , content
  45   ]
  46
  47 getHeaders :: Handle -> IO [(String, String)]
  48 getHeaders h = do
  49   l <- catch (hGetLine h) eofHandler
  50   let (name, val) = span (/= ':') l
  51   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
  52   where eofHandler e
  53           | isEOFError e = throw UnexpectedServerTermination
  54           | otherwise = throw e
  55
  56 type RequestMap = HM.HashMap LspId ClientMethod
  57
  58 newRequestMap :: RequestMap
  59 newRequestMap = HM.empty
  60
  61 updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
  62 updateRequestMap reqMap id method = HM.insert id method reqMap
  63
  64 getRequestMap :: [FromClientMessage] -> RequestMap
  65 getRequestMap = foldl helper HM.empty
  66  where
  67   helper acc msg = case msg of
  68     (ReqInitialize val) -> insert val acc
  69     (ReqShutdown val) -> insert val acc
  70     (ReqHover val) -> insert val acc
  71     (ReqCompletion val) -> insert val acc
  72     (ReqCompletionItemResolve val) -> insert val acc
  73     (ReqSignatureHelp val) -> insert val acc
  74     (ReqDefinition val) -> insert val acc
  75     (ReqTypeDefinition val) -> insert val acc
  76     (ReqFindReferences val) -> insert val acc
  77     (ReqDocumentHighlights val) -> insert val acc
  78     (ReqDocumentSymbols val) -> insert val acc
  79     (ReqWorkspaceSymbols val) -> insert val acc
  80     (ReqCodeAction val) -> insert val acc
  81     (ReqCodeLens val) -> insert val acc
  82     (ReqCodeLensResolve val) -> insert val acc
  83     (ReqDocumentFormatting val) -> insert val acc
  84     (ReqDocumentRangeFormatting val) -> insert val acc
  85     (ReqDocumentOnTypeFormatting val) -> insert val acc
  86     (ReqRename val) -> insert val acc
  87     (ReqExecuteCommand val) -> insert val acc
  88     (ReqDocumentLink val) -> insert val acc
  89     (ReqDocumentLinkResolve val) -> insert val acc
  90     (ReqWillSaveWaitUntil val) -> insert val acc
  91     _ -> acc
  92   insert m = HM.insert (m ^. id) (m ^. method)
  93
  94 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
  95 matchResponseMsgType req = case req of
  96   Initialize                    -> RspInitialize . decoded
  97   Shutdown                      -> RspShutdown . decoded
  98   TextDocumentHover             -> RspHover . decoded
  99   TextDocumentCompletion        -> RspCompletion . decoded
 100   CompletionItemResolve         -> RspCompletionItemResolve . decoded
 101   TextDocumentSignatureHelp     -> RspSignatureHelp . decoded
 102   TextDocumentDefinition        -> RspDefinition . decoded
 103   TextDocumentTypeDefinition    -> RspTypeDefinition . decoded
 104   TextDocumentReferences        -> RspFindReferences . decoded
 105   TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
 106   TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded
 107   WorkspaceSymbol               -> RspWorkspaceSymbols . decoded
 108   TextDocumentCodeAction        -> RspCodeAction . decoded
 109   TextDocumentCodeLens          -> RspCodeLens . decoded
 110   CodeLensResolve               -> RspCodeLensResolve . decoded
 111   TextDocumentFormatting        -> RspDocumentFormatting . decoded
 112   TextDocumentRangeFormatting   -> RspDocumentRangeFormatting . decoded
 113   TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting . decoded
 114   TextDocumentRename            -> RspRename . decoded
 115   WorkspaceExecuteCommand       -> RspExecuteCommand . decoded
 116   TextDocumentDocumentLink      -> RspDocumentLink . decoded
 117   DocumentLinkResolve           -> RspDocumentLinkResolve . decoded
 118   TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
 119   CustomClientMethod{}          -> RspCustomServer . 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