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.Exception
   7 import           Control.Lens
   8 import qualified Data.ByteString.Lazy.Char8    as B
   9 import           Data.Maybe
  10 import           System.IO
  11 import           System.IO.Error
  12 import           Language.Haskell.LSP.Types
  13 import           Language.Haskell.LSP.Types.Lens
  14                                          hiding ( error )
  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   -> error "Couldn't read Content-Length header"
  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     (ReqFindReferences val) -> insert val acc
  76     (ReqDocumentHighlights val) -> insert val acc
  77     (ReqDocumentSymbols val) -> insert val acc
  78     (ReqWorkspaceSymbols val) -> insert val acc
  79     (ReqCodeAction val) -> insert val acc
  80     (ReqCodeLens val) -> insert val acc
  81     (ReqCodeLensResolve val) -> insert val acc
  82     (ReqDocumentFormatting val) -> insert val acc
  83     (ReqDocumentRangeFormatting val) -> insert val acc
  84     (ReqDocumentOnTypeFormatting val) -> insert val acc
  85     (ReqRename val) -> insert val acc
  86     (ReqExecuteCommand val) -> insert val acc
  87     (ReqDocumentLink val) -> insert val acc
  88     (ReqDocumentLinkResolve val) -> insert val acc
  89     (ReqWillSaveWaitUntil val) -> insert val acc
  90     _ -> acc
  91   insert m = HM.insert (m ^. id) (m ^. method)
  92
  93 matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
  94 matchResponseMsgType req = case req of
  95   Initialize                    -> RspInitialize . decoded
  96   Shutdown                      -> RspShutdown . decoded
  97   TextDocumentHover             -> RspHover . decoded
  98   TextDocumentCompletion        -> RspCompletion . decoded
  99   CompletionItemResolve         -> RspCompletionItemResolve . decoded
 100   TextDocumentSignatureHelp     -> RspSignatureHelp . decoded
 101   TextDocumentDefinition        -> RspDefinition . decoded
 102   TextDocumentReferences        -> RspFindReferences . decoded
 103   TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
 104   TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded
 105   WorkspaceSymbol               -> RspWorkspaceSymbols . decoded
 106   TextDocumentCodeAction        -> RspCodeAction . decoded
 107   TextDocumentCodeLens          -> RspCodeLens . decoded
 108   CodeLensResolve               -> RspCodeLensResolve . decoded
 109   TextDocumentFormatting        -> RspDocumentFormatting . decoded
 110   TextDocumentRangeFormatting   -> RspDocumentRangeFormatting . decoded
 111   TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting . decoded
 112   TextDocumentRename            -> RspRename . decoded
 113   WorkspaceExecuteCommand       -> RspExecuteCommand . decoded
 114   TextDocumentDocumentLink      -> RspDocumentLink . decoded
 115   DocumentLinkResolve           -> RspDocumentLinkResolve . decoded
 116   TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
 117   x                             -> error . ((show x ++ " is not a request: ") ++) . show
 118   where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "
 119                                         ++ show req ++ "\n" ++ show x)
 120                               (decode x)
 121
 122 decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
 123 decodeFromServerMsg reqMap bytes =
 124   case HM.lookup "method" (fromJust $ decode bytes :: Object) of
 125     Just methodStr -> case fromJSON methodStr of
 126       Success method -> case method of
 127         -- We can work out the type of the message
 128         TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
 129         WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes
 130         WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes
 131         CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes
 132         TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes
 133         WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes
 134         ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes
 135         ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes
 136         WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
 137         WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
 138         WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
 139
 140       Error e -> error e
 141
 142     Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
 143       Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
 144         Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
 145         Nothing  -> error "Couldn't match up response with request"
 146       Nothing -> error "Couldn't decode message"