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 replay :: FilePath -> IO Int
  19 replay fp = do
  20
  21   (Just serverIn, Just serverOut, _, _) <- createProcess
  22     (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in  = CreatePipe
  23                                                        , std_out = CreatePipe
  24                                                        }
  25
  26   hSetBuffering serverIn  NoBuffering
  27   hSetBuffering serverOut NoBuffering
  28
  29   -- whether to send the next request
  30   semaphore <- newEmptyMVar
  31
  32   -- listen to server
  33   forkIO $ forever $ do
  34     headers <- getHeaders serverOut
  35     case read . init <$> lookup "Content-Length" headers of
  36       Nothing   -> error "Couldn't read Content-Length header"
  37       Just size -> do
  38         message <- B.hGet serverOut size
  39         case decode message :: Maybe (LSP.ResponseMessage Value) of
  40           Just _  -> putMVar semaphore ()
  41           Nothing -> return () -- might be a notification or something, that's ok
  42
  43   -- the recorded client input to the server
  44   clientRecIn <- openFile fp ReadMode
  45   null        <- openFile "/dev/null" WriteMode
  46
  47   -- send inialize request ourselves since haskell-lsp consumes it
  48   -- rest are handled via `handlers`
  49   sendInitialize clientRecIn serverIn
  50
  51   Control.runWithHandles clientRecIn
  52                          null
  53                          (const $ Right (), const $ return Nothing)
  54                          (handlers serverIn semaphore)
  55                          def
  56                          Nothing
  57                          Nothing
  58  where
  59   sendInitialize recH serverH = do
  60     headers <- getHeaders recH
  61     case read . init <$> lookup "Content-Length" headers of
  62       Nothing   -> error "Failed to read the read the initialize request"
  63       Just size -> do
  64         message <- B.hGet recH size
  65         B.hPut serverH (addHeader message)
  66         -- bring the file back to the start for haskell-lsp
  67         hSeek recH AbsoluteSeek 0
  68
  69
  70 handlers :: Handle -> MVar () -> Handlers
  71 handlers serverH flag = def
  72   {
  73     -- Requests
  74     hoverHandler                             = Just request
  75   , completionHandler                        = Just request
  76   , completionResolveHandler                 = Just request
  77   , signatureHelpHandler                     = Just request
  78   , definitionHandler                        = Just request
  79   , referencesHandler                        = Just request
  80   , documentHighlightHandler                 = Just request
  81   , documentSymbolHandler                    = Just request
  82   , workspaceSymbolHandler                   = Just request
  83   , codeActionHandler                        = Just request
  84   , codeLensHandler                          = Just request
  85   , codeLensResolveHandler                   = Just request
  86   , documentFormattingHandler                = Just request
  87   , documentRangeFormattingHandler           = Just request
  88   , documentTypeFormattingHandler            = Just request
  89   , renameHandler                            = Just request
  90   , documentLinkHandler                      = Just request
  91   , documentLinkResolveHandler               = Just request
  92   , executeCommandHandler                    = Just request
  93     -- Notifications
  94   , didChangeConfigurationParamsHandler      = Just notification
  95   , didOpenTextDocumentNotificationHandler   = Just notification
  96   , didChangeTextDocumentNotificationHandler = Just notification
  97   , didCloseTextDocumentNotificationHandler  = Just notification
  98   , didSaveTextDocumentNotificationHandler   = Just notification
  99   , didChangeWatchedFilesNotificationHandler = Just notification
 100   , initializedHandler                       = Just notification
 101   , willSaveTextDocumentNotificationHandler  = Just notification
 102   , cancelNotificationHandler                = Just notification
 103   , responseHandler                          = Just notification
 104   }
 105  where
 106   notification m = do
 107     B.hPut serverH $ addHeader (encode m)
 108     putStrLn "sent a notification"
 109   request m = do
 110     B.hPut serverH $ addHeader (encode m)
 111     putStrLn "sent a request, waiting for a response"
 112     takeMVar flag
 113     putStrLn "got a response"
 114
 115 addHeader :: B.ByteString -> B.ByteString
 116 addHeader content = B.concat
 117   [ "Content-Length: "
 118   , B.pack $ show $ B.length content
 119   , "\r\n"
 120   , "\r\n"
 121   , content
 122   ]
 123
 124 getHeaders :: Handle -> IO [(String, String)]
 125 getHeaders h = do
 126   l <- hGetLine h
 127   let (name, val) = span (/= ':') l
 128   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h