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