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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Haskell.LSP.Test.Recorded
   3   ( replay
   4   )
   5 where
   6
   7 import           Control.Concurrent
   8 import           Control.Monad
   9 import           Data.Default
  10 import           Language.Haskell.LSP.Control  as Control
  11 import qualified Data.ByteString.Lazy.Char8    as B
  12 import           Language.Haskell.LSP.Core
  13 import qualified Language.Haskell.LSP.Types    as LSP
  14 import           Data.Aeson
  15 import           System.IO
  16 import           System.Process
  17
  18 -- | Replays a recorded client output and
  19 -- makes sure it matches up with an expected response.
  20 replay :: FilePath -- ^ The client output to replay to the server.
  21        -> FilePath -- ^ The expected response from the server.
  22        -> IO Int
  23 replay cfp sfp = do
  24
  25   (Just serverIn, Just serverOut, _, _) <- createProcess
  26     (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in  = CreatePipe
  27                                                        , std_out = CreatePipe
  28                                                        }
  29
  30   hSetBuffering serverIn  NoBuffering
  31   hSetBuffering serverOut NoBuffering
  32
  33   -- whether to send the next request
  34   semaphore <- newEmptyMVar
  35
  36   -- the recorded client input to the server
  37   clientRecIn <- openFile cfp ReadMode
  38   serverRecIn <- openFile sfp ReadMode
  39   null        <- openFile "/dev/null" WriteMode
  40
  41   -- listen to server
  42   forkIO $ forever $ do
  43     msg <- getNextMessage serverOut
  44     expectedMsg <- getNextMessage serverRecIn
  45     putStrLn $ "received: " ++ (show msg)
  46     putStrLn $ "next expected: " ++ (show expectedMsg)
  47     case decode msg :: Maybe (LSP.RequestMessage Value Value Value) of
  48       Just _ -> putStrLn "ignoring request" >> return ()
  49       Nothing -> when (msg /= expectedMsg) $ error ("Expected " ++ show expectedMsg ++ " but got " ++ show msg)
  50     case decode msg :: Maybe (LSP.ResponseMessage Value) of
  51       Just _  -> putMVar semaphore ()
  52       Nothing -> return () -- might be a notification or something, that's ok
  53
  54   -- send inialize request ourselves since haskell-lsp consumes it
  55   -- rest are handled via `handlers`
  56   sendInitialize clientRecIn serverIn
  57
  58   Control.runWithHandles clientRecIn
  59                          null
  60                          (const $ Right (), const $ return Nothing)
  61                          (handlers serverIn semaphore)
  62                          def
  63                          Nothing
  64                          Nothing
  65  where
  66   sendInitialize recH serverH = do
  67     message <- getNextMessage recH
  68     B.hPut serverH (addHeader message)
  69     -- bring the file back to the start for haskell-lsp
  70     hSeek recH AbsoluteSeek 0
  71
  72 -- | Fetches the next message bytes based on
  73 -- the Content-Length header
  74 getNextMessage :: Handle -> IO B.ByteString
  75 getNextMessage h = do
  76   headers <- getHeaders h
  77   case read . init <$> lookup "Content-Length" headers of
  78     Nothing   -> error "Couldn't read Content-Length header"
  79     Just size -> B.hGet h size
  80
  81
  82 handlers :: Handle -> MVar () -> Handlers
  83 handlers serverH flag = def
  84   {
  85     -- Requests
  86     hoverHandler                             = Just request
  87   , completionHandler                        = Just request
  88   , completionResolveHandler                 = Just request
  89   , signatureHelpHandler                     = Just request
  90   , definitionHandler                        = Just request
  91   , referencesHandler                        = Just request
  92   , documentHighlightHandler                 = Just request
  93   , documentSymbolHandler                    = Just request
  94   , workspaceSymbolHandler                   = Just request
  95   , codeActionHandler                        = Just request
  96   , codeLensHandler                          = Just request
  97   , codeLensResolveHandler                   = Just request
  98   , documentFormattingHandler                = Just request
  99   , documentRangeFormattingHandler           = Just request
 100   , documentTypeFormattingHandler            = Just request
 101   , renameHandler                            = Just request
 102   , documentLinkHandler                      = Just request
 103   , documentLinkResolveHandler               = Just request
 104   , executeCommandHandler                    = Just request
 105     -- Notifications
 106   , didChangeConfigurationParamsHandler      = Just notification
 107   , didOpenTextDocumentNotificationHandler   = Just notification
 108   , didChangeTextDocumentNotificationHandler = Just notification
 109   , didCloseTextDocumentNotificationHandler  = Just notification
 110   , didSaveTextDocumentNotificationHandler   = Just notification
 111   , didChangeWatchedFilesNotificationHandler = Just notification
 112   , initializedHandler                       = Just notification
 113   , willSaveTextDocumentNotificationHandler  = Just notification
 114   , cancelNotificationHandler                = Just notification
 115   , responseHandler                          = Just notification
 116   }
 117  where
 118   notification m = do
 119     B.hPut serverH $ addHeader (encode m)
 120     putStrLn "sent a notification"
 121   request m = do
 122     B.hPut serverH $ addHeader (encode m)
 123     putStrLn "sent a request, waiting for a response"
 124     takeMVar flag
 125     putStrLn "got a response"
 126
 127 addHeader :: B.ByteString -> B.ByteString
 128 addHeader content = B.concat
 129   [ "Content-Length: "
 130   , B.pack $ show $ B.length content
 131   , "\r\n"
 132   , "\r\n"
 133   , content
 134   ]
 135
 136 getHeaders :: Handle -> IO [(String, String)]
 137 getHeaders h = do
 138   l <- hGetLine h
 139   let (name, val) = span (/= ':') l
 140   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h