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