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           Data.Default
   9 import           Language.Haskell.LSP.Control  as Control
  10 import qualified Data.ByteString.Lazy.Char8    as B
  11 import           Language.Haskell.LSP.Core
  12 import qualified Language.Haskell.LSP.Types    as LSP
  13 import           Data.Aeson
  14 import           Data.List
  15 import           Data.Maybe
  16 import           Control.Lens
  17 import           Control.Monad
  18 import           System.IO
  19 import           System.Directory
  20 import           System.Process
  21
  22 -- | Replays a recorded client output and
  23 -- makes sure it matches up with an expected response.
  24 replay
  25   :: FilePath -- ^ The client output to replay to the server.
  26   -> FilePath -- ^ The expected response from the server.
  27   -> IO Bool
  28 replay cfp sfp = do
  29
  30   -- need to keep hold of current directory since haskell-lsp changes it
  31   prevDir <- getCurrentDirectory
  32
  33   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  34     (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in  = CreatePipe
  35                                                        , std_out = CreatePipe
  36                                                        }
  37
  38   hSetBuffering serverIn  NoBuffering
  39   hSetBuffering serverOut NoBuffering
  40
  41   -- todo: use qsem
  42   -- whether to send the next request
  43   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  44   -- whether to send the next response
  45   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  46   let semas = (reqSema, rspSema)
  47
  48   didPass      <- newEmptyMVar
  49
  50   -- the recorded client input to the server
  51   clientRecIn  <- openFile cfp ReadMode
  52   serverRecIn  <- openFile sfp ReadMode
  53   null         <- openFile "/dev/null" WriteMode
  54
  55   expectedMsgs <- getAllMessages serverRecIn
  56
  57   -- listen to server
  58   forkIO $ listenServer expectedMsgs serverOut semas didPass
  59
  60   -- start client replay
  61   forkIO $ do
  62     Control.runWithHandles clientRecIn
  63                            null
  64                            (const $ Right (), const $ return Nothing)
  65                            (handlers serverIn semas)
  66                            def
  67                            Nothing
  68                            Nothing
  69
  70     -- todo: we shouldn't do this, we should check all notifications were delivered first
  71     putMVar didPass True
  72
  73   result <- takeMVar didPass
  74   terminateProcess serverProc
  75
  76   -- restore directory
  77   setCurrentDirectory prevDir
  78
  79   return result
  80
  81 -- todo: Maybe make a reader monad and a fail function for it?
  82 listenServer
  83   :: [B.ByteString]
  84   -> Handle
  85   -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
  86   -> MVar Bool
  87   -> IO ()
  88 listenServer [] _ _ passVar = putMVar passVar True
  89 listenServer expectedMsgs h semas@(reqSema, rspSema) passVar = do
  90   msg <- getNextMessage h
  91   putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
  92   if inRightOrder msg expectedMsgs
  93     then do
  94
  95       whenResponse msg $ \res -> do
  96         putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
  97         putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
  98
  99       whenRequest msg $ \req -> do
 100         putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
 101         putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 102
 103       whenNotification msg $ \n -> putStrLn $ "Got notification " ++ (show (n ^. LSP.method))
 104
 105       when (not (msg `elem` expectedMsgs)) $ do
 106         putStrLn "Got an unexpected message"
 107         putMVar passVar False
 108
 109       listenServer (delete msg expectedMsgs) h semas passVar
 110     else do
 111       putStrLn $ "Got: " ++ show msg ++ "\n Expected: " ++ show
 112         (head (filter (not . isNotification) expectedMsgs))
 113       putMVar passVar False
 114
 115 isNotification :: B.ByteString -> Bool
 116 isNotification msg =
 117   isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
 118
 119 whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO ()
 120 whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
 121   Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
 122   _         -> return ()
 123
 124 whenRequest
 125   :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO ()
 126 whenRequest msg =
 127   forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
 128
 129 whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> IO ()) -> IO ()
 130 whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
 131
 132 -- TODO: QuickCheck tests?
 133 -- | Checks wether or not the message appears in the right order
 134 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 135 -- given N2, notification order doesn't matter.
 136 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 137 -- given REQ1
 138 -- @ N1 N3 N4 N5 REQ2 RES1 @
 139 -- given RES1
 140 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 141 -- Order of requests and responses matter
 142 inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
 143 inRightOrder _        []   = error "why is this empty"
 144 inRightOrder received msgs = received `elem` valid
 145  where
 146   valid   = takeWhile canSkip msgs ++ firstNonSkip
 147   -- we don't care about the order of notifications
 148   canSkip = isNotification
 149   nonSkip = dropWhile canSkip msgs
 150   firstNonSkip | null nonSkip = []
 151                | otherwise    = [head nonSkip]
 152
 153 getAllMessages :: Handle -> IO [B.ByteString]
 154 getAllMessages h = do
 155   done <- hIsEOF h
 156   if done
 157     then return []
 158     else do
 159       msg <- getNextMessage h
 160       (msg :) <$> getAllMessages h
 161
 162 -- | Fetches the next message bytes based on
 163 -- the Content-Length header
 164 getNextMessage :: Handle -> IO B.ByteString
 165 getNextMessage h = do
 166   headers <- getHeaders h
 167   case read . init <$> lookup "Content-Length" headers of
 168     Nothing   -> error "Couldn't read Content-Length header"
 169     Just size -> B.hGet h size
 170
 171
 172 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
 173 handlers serverH (reqSema, rspSema) = def
 174   {
 175     -- Requests
 176     hoverHandler                             = Just request
 177   , completionHandler                        = Just request
 178   , completionResolveHandler                 = Just request
 179   , signatureHelpHandler                     = Just request
 180   , definitionHandler                        = Just request
 181   , referencesHandler                        = Just request
 182   , documentHighlightHandler                 = Just request
 183   , documentSymbolHandler                    = Just request
 184   , workspaceSymbolHandler                   = Just request
 185   , codeActionHandler                        = Just request
 186   , codeLensHandler                          = Just request
 187   , codeLensResolveHandler                   = Just request
 188   , documentFormattingHandler                = Just request
 189   , documentRangeFormattingHandler           = Just request
 190   , documentTypeFormattingHandler            = Just request
 191   , renameHandler                            = Just request
 192   , documentLinkHandler                      = Just request
 193   , documentLinkResolveHandler               = Just request
 194   , executeCommandHandler                    = Just request
 195   , initializeRequestHandler             = Just request
 196     -- Notifications
 197   , didChangeConfigurationParamsHandler      = Just notification
 198   , didOpenTextDocumentNotificationHandler   = Just notification
 199   , didChangeTextDocumentNotificationHandler = Just notification
 200   , didCloseTextDocumentNotificationHandler  = Just notification
 201   , didSaveTextDocumentNotificationHandler   = Just notification
 202   , didChangeWatchedFilesNotificationHandler = Just notification
 203   , initializedHandler                       = Just notification
 204   , willSaveTextDocumentNotificationHandler  = Just notification
 205   , cancelNotificationHandler                = Just notification
 206   , exitNotificationHandler                  = Just notification
 207     -- Responses
 208   , responseHandler                          = Just response
 209   }
 210  where
 211   -- TODO: May need to prevent premature exit notification being sent
 212   -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 213   --   putStrLn "Will send exit notification soon"
 214   --   threadDelay 10000000
 215   --   B.hPut serverH $ addHeader (encode msg)
 216   notification msg@(LSP.NotificationMessage _ m _) = do
 217     B.hPut serverH $ addHeader (encode msg)
 218
 219     putStrLn $ "Sent a notification " ++ show m
 220
 221   request msg@(LSP.RequestMessage _ id m _) = do
 222     B.hPut serverH $ addHeader (encode msg)
 223     putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 224
 225     rspId <- takeMVar reqSema
 226     when (LSP.responseId id /= rspId)
 227       $  error
 228       $  "Expected id "
 229       ++ show id
 230       ++ ", got "
 231       ++ show rspId
 232
 233   response msg@(LSP.ResponseMessage _ id _ _) = do
 234     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 235     reqId <- takeMVar rspSema
 236     if LSP.responseId reqId /= id
 237       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 238       else do
 239         B.hPut serverH $ addHeader (encode msg)
 240         putStrLn $ "Sent response to request id " ++ show id
 241
 242 addHeader :: B.ByteString -> B.ByteString
 243 addHeader content = B.concat
 244   [ "Content-Length: "
 245   , B.pack $ show $ B.length content
 246   , "\r\n"
 247   , "\r\n"
 248   , content
 249   ]
 250
 251 getHeaders :: Handle -> IO [(String, String)]
 252 getHeaders h = do
 253   l <- hGetLine h
 254   let (name, val) = span (/= ':') l
 255   if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h