-- | A testing tool for replaying captured client logs back to a server,
-- and validating that the server output matches up with another log.
module Language.Haskell.LSP.Test.Replay
  ( replaySession
  )
where

import           Prelude hiding (id)
import           Control.Concurrent
import           Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8    as B
import qualified Data.Text                     as T
import           Language.Haskell.LSP.Capture
import           Language.Haskell.LSP.Messages
import           Language.Haskell.LSP.Types
import           Language.Haskell.LSP.Types.Lens as LSP
import           Data.Aeson
import           Data.Default
import           Data.List
import           Data.Maybe
import           Control.Lens hiding (List)
import           Control.Monad
import           System.FilePath
import           System.IO
import           Language.Haskell.LSP.Test
import           Language.Haskell.LSP.Test.Compat
import           Language.Haskell.LSP.Test.Files
import           Language.Haskell.LSP.Test.Decoding
import           Language.Haskell.LSP.Test.Messages
import           Language.Haskell.LSP.Test.Server
import           Language.Haskell.LSP.Test.Session

-- | Replays a captured client output and
-- makes sure it matches up with an expected response.
-- The session directory should have a captured session file in it
-- named "session.log".
-- You can get these capture files from 'Language.Haskell.LSP.resCaptureFile' in
-- haskell-lsp.
replaySession :: String -- ^ The command to run the server.
              -> FilePath -- ^ The recorded session directory.
              -> IO ()
replaySession :: String -> String -> IO ()
replaySession String
serverExe String
sessionDir = do

  [ByteString]
entries <- ByteString -> [ByteString]
B.lines (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile (String
sessionDir String -> String -> String
</> String
"session.log")

  -- decode session
  let unswappedEvents :: [Event]
unswappedEvents = (ByteString -> Event) -> [ByteString] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Event -> Event
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Event -> Event)
-> (ByteString -> Maybe Event) -> ByteString -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Event
forall a. FromJSON a => ByteString -> Maybe a
decode) [ByteString]
entries

  String
-> Bool -> (Handle -> Handle -> ProcessHandle -> IO ()) -> IO ()
forall a.
String
-> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a
withServer String
serverExe Bool
False ((Handle -> Handle -> ProcessHandle -> IO ()) -> IO ())
-> (Handle -> Handle -> ProcessHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
serverIn Handle
serverOut ProcessHandle
serverProc -> do

    Int
pid <- ProcessHandle -> IO Int
getProcessID ProcessHandle
serverProc
    [Event]
events <- Int -> [Event] -> [Event]
swapCommands Int
pid ([Event] -> [Event]) -> IO [Event] -> IO [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Event] -> IO [Event]
swapFiles String
sessionDir [Event]
unswappedEvents

    let clientEvents :: [Event]
clientEvents = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isClientMsg [Event]
events
        serverEvents :: [Event]
serverEvents = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter Event -> Bool
isServerMsg [Event]
events
        clientMsgs :: [FromClientMessage]
clientMsgs = (Event -> FromClientMessage) -> [Event] -> [FromClientMessage]
forall a b. (a -> b) -> [a] -> [b]
map (\(FromClient UTCTime
_ FromClientMessage
msg) -> FromClientMessage
msg) [Event]
clientEvents
        serverMsgs :: [FromServerMessage]
serverMsgs = (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (FromServerMessage -> Bool) -> FromServerMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> Bool
shouldSkip) ([FromServerMessage] -> [FromServerMessage])
-> [FromServerMessage] -> [FromServerMessage]
forall a b. (a -> b) -> a -> b
$ (Event -> FromServerMessage) -> [Event] -> [FromServerMessage]
forall a b. (a -> b) -> [a] -> [b]
map (\(FromServer UTCTime
_ FromServerMessage
msg) -> FromServerMessage
msg) [Event]
serverEvents
        requestMap :: RequestMap
requestMap = [FromClientMessage] -> RequestMap
getRequestMap [FromClientMessage]
clientMsgs

    MVar LspId
reqSema <- IO (MVar LspId)
forall a. IO (MVar a)
newEmptyMVar
    MVar LspIdRsp
rspSema <- IO (MVar LspIdRsp)
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
passSema <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
mainThread <- IO ThreadId
myThreadId

    ThreadId
sessionThread <- IO ThreadId -> IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
      Handle
-> Handle
-> ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session ()
-> IO ()
forall a.
Handle
-> Handle
-> ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session a
-> IO a
runSessionWithHandles Handle
serverIn Handle
serverOut ProcessHandle
serverProc
                            ([FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [FromServerMessage]
serverMsgs RequestMap
requestMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThread)
                            SessionConfig
forall a. Default a => a
def
                            ClientCapabilities
fullCaps
                            String
sessionDir
                            (() -> Session ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- No finalizer cleanup
                            ([FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
clientMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema)
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
passSema
    ThreadId -> IO ()
killThread ThreadId
sessionThread

  where
    isClientMsg :: Event -> Bool
isClientMsg (FromClient UTCTime
_ FromClientMessage
_) = Bool
True
    isClientMsg Event
_                = Bool
False

    isServerMsg :: Event -> Bool
isServerMsg (FromServer UTCTime
_ FromServerMessage
_) = Bool
True
    isServerMsg Event
_                = Bool
False

sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [] MVar LspId
_ MVar LspIdRsp
_ = () -> Session ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendMessages (FromClientMessage
nextMsg:[FromClientMessage]
remainingMsgs) MVar LspId
reqSema MVar LspIdRsp
rspSema =
  (forall b c.
 (ToJSON b, ToJSON c) =>
 RequestMessage ClientMethod b c -> Session ())
-> (forall d. ToJSON d => ResponseMessage d -> Session ())
-> (forall e.
    ToJSON e =>
    NotificationMessage ClientMethod e -> Session ())
-> FromClientMessage
-> Session ()
forall a.
(forall b c.
 (ToJSON b, ToJSON c) =>
 RequestMessage ClientMethod b c -> a)
-> (forall d. ToJSON d => ResponseMessage d -> a)
-> (forall e. ToJSON e => NotificationMessage ClientMethod e -> a)
-> FromClientMessage
-> a
handleClientMessage forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> Session ()
request forall d. ToJSON d => ResponseMessage d -> Session ()
response forall e.
ToJSON e =>
NotificationMessage ClientMethod e -> Session ()
notification FromClientMessage
nextMsg
 where
  -- TODO: May need to prevent premature exit notification being sent
  notification :: NotificationMessage ClientMethod a -> Session ()
notification msg :: NotificationMessage ClientMethod a
msg@(NotificationMessage Text
_ ClientMethod
Exit a
_) = do
    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Will send exit notification soon"
    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
10000000
    NotificationMessage ClientMethod a -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage ClientMethod a
msg

    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"Done"

  notification msg :: NotificationMessage ClientMethod a
msg@(NotificationMessage Text
_ ClientMethod
m a
_) = do
    NotificationMessage ClientMethod a -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage ClientMethod a
msg

    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent a notification " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
m

    [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema

  request :: RequestMessage ClientMethod a b -> Session ()
request msg :: RequestMessage ClientMethod a b
msg@(RequestMessage Text
_ LspId
id ClientMethod
m a
_) = do
    RequestMessage ClientMethod a b -> Session ()
forall b c.
(ToJSON b, ToJSON c) =>
RequestMessage ClientMethod b c -> Session ()
sendRequestMessage RequestMessage ClientMethod a b
msg
    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
"Sent a request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ClientMethod -> String
forall a. Show a => a -> String
show ClientMethod
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nWaiting for a response"

    LspIdRsp
rsp <- IO LspIdRsp -> Session LspIdRsp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LspIdRsp -> Session LspIdRsp)
-> IO LspIdRsp -> Session LspIdRsp
forall a b. (a -> b) -> a -> b
$ MVar LspIdRsp -> IO LspIdRsp
forall a. MVar a -> IO a
takeMVar MVar LspIdRsp
rspSema
    Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LspId -> LspIdRsp
responseId LspId
id LspIdRsp -> LspIdRsp -> Bool
forall a. Eq a => a -> a -> Bool
/= LspIdRsp
rsp) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$
      String -> Session ()
forall a. HasCallStack => String -> a
error (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ String
"Expected id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
rsp

    [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema

  response :: ResponseMessage a -> Session ()
response msg :: ResponseMessage a
msg@(ResponseMessage Text
_ LspIdRsp
id Either ResponseError a
_) = do
    IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Waiting for request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the server"
    LspId
reqId <- IO LspId -> Session LspId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LspId -> Session LspId) -> IO LspId -> Session LspId
forall a b. (a -> b) -> a -> b
$ MVar LspId -> IO LspId
forall a. MVar a -> IO a
takeMVar MVar LspId
reqSema
    if LspId -> LspIdRsp
responseId LspId
reqId LspIdRsp -> LspIdRsp -> Bool
forall a. Eq a => a -> a -> Bool
/= LspIdRsp
id
      then String -> Session ()
forall a. HasCallStack => String -> a
error (String -> Session ()) -> String -> Session ()
forall a b. (a -> b) -> a -> b
$ String
"Expected id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
reqId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show LspId
reqId
      else do
        ResponseMessage a -> Session ()
forall d. ToJSON d => ResponseMessage d -> Session ()
sendResponse ResponseMessage a
msg
        IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sent response to request id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show LspIdRsp
id

    [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
sendMessages [FromClientMessage]
remainingMsgs MVar LspId
reqSema MVar LspIdRsp
rspSema

sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
sendRequestMessage :: RequestMessage ClientMethod a b -> Session ()
sendRequestMessage RequestMessage ClientMethod a b
req = do
  -- Update the request map
  MVar RequestMap
reqMap <- SessionContext -> MVar RequestMap
requestMap (SessionContext -> MVar RequestMap)
-> Session SessionContext -> Session (MVar RequestMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session SessionContext
forall r (m :: * -> *). HasReader r m => m r
ask
  IO () -> Session ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ MVar RequestMap -> (RequestMap -> IO RequestMap) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestMap
reqMap ((RequestMap -> IO RequestMap) -> IO ())
-> (RequestMap -> IO RequestMap) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \RequestMap
r -> RequestMap -> IO RequestMap
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMap -> IO RequestMap) -> RequestMap -> IO RequestMap
forall a b. (a -> b) -> a -> b
$ RequestMap -> LspId -> ClientMethod -> RequestMap
updateRequestMap RequestMap
r (RequestMessage ClientMethod a b
req RequestMessage ClientMethod a b
-> Getting LspId (RequestMessage ClientMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ClientMethod a b) LspId
forall s a. HasId s a => Lens' s a
LSP.id) (RequestMessage ClientMethod a b
req RequestMessage ClientMethod a b
-> Getting
     ClientMethod (RequestMessage ClientMethod a b) ClientMethod
-> ClientMethod
forall s a. s -> Getting a s a -> a
^. Getting ClientMethod (RequestMessage ClientMethod a b) ClientMethod
forall s a. HasMethod s a => Lens' s a
method)

  RequestMessage ClientMethod a b -> Session ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage RequestMessage ClientMethod a b
req


isNotification :: FromServerMessage -> Bool
isNotification :: FromServerMessage -> Bool
isNotification (NotPublishDiagnostics      PublishDiagnosticsNotification
_) = Bool
True
isNotification (NotLogMessage              LogMessageNotification
_) = Bool
True
isNotification (NotShowMessage             ShowMessageNotification
_) = Bool
True
isNotification (NotCancelRequestFromServer CancelNotificationServer
_) = Bool
True
isNotification FromServerMessage
_                              = Bool
False

listenServer :: [FromServerMessage]
             -> RequestMap
             -> MVar LspId
             -> MVar LspIdRsp
             -> MVar ()
             -> ThreadId
             -> Handle
             -> SessionContext
             -> IO ()
listenServer :: [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [] RequestMap
_ MVar LspId
_ MVar LspIdRsp
_ MVar ()
passSema ThreadId
_ Handle
_ SessionContext
_ = MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
passSema ()
listenServer [FromServerMessage]
expectedMsgs RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx = do

  ByteString
msgBytes <- Handle -> IO ByteString
getNextMessage Handle
serverOut
  let msg :: FromServerMessage
msg = RequestMap -> ByteString -> FromServerMessage
decodeFromServerMsg RequestMap
reqMap ByteString
msgBytes

  (forall b c. RequestMessage ServerMethod b c -> IO ())
-> (forall d. ResponseMessage d -> IO ())
-> (forall e. NotificationMessage ServerMethod e -> IO ())
-> FromServerMessage
-> IO ()
forall a.
(forall b c. RequestMessage ServerMethod b c -> a)
-> (forall d. ResponseMessage d -> a)
-> (forall e. NotificationMessage ServerMethod e -> a)
-> FromServerMessage
-> a
handleServerMessage forall b c. RequestMessage ServerMethod b c -> IO ()
request forall d. ResponseMessage d -> IO ()
response forall e. NotificationMessage ServerMethod e -> IO ()
notification FromServerMessage
msg

  if FromServerMessage -> Bool
shouldSkip FromServerMessage
msg
    then [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer [FromServerMessage]
expectedMsgs RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx
    else if FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
msg [FromServerMessage]
expectedMsgs
      then [FromServerMessage]
-> RequestMap
-> MVar LspId
-> MVar LspIdRsp
-> MVar ()
-> ThreadId
-> Handle
-> SessionContext
-> IO ()
listenServer (FromServerMessage -> [FromServerMessage] -> [FromServerMessage]
forall a. Eq a => a -> [a] -> [a]
delete FromServerMessage
msg [FromServerMessage]
expectedMsgs) RequestMap
reqMap MVar LspId
reqSema MVar LspIdRsp
rspSema MVar ()
passSema ThreadId
mainThreadId Handle
serverOut SessionContext
ctx
      else let remainingMsgs :: [FromServerMessage]
remainingMsgs = (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool)
-> (FromServerMessage -> Bool) -> FromServerMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromServerMessage -> Bool
isNotification) [FromServerMessage]
expectedMsgs
                [FromServerMessage] -> [FromServerMessage] -> [FromServerMessage]
forall a. [a] -> [a] -> [a]
++ [[FromServerMessage] -> FromServerMessage
forall a. [a] -> a
head ([FromServerMessage] -> FromServerMessage)
-> [FromServerMessage] -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool)
-> [FromServerMessage] -> [FromServerMessage]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile FromServerMessage -> Bool
isNotification [FromServerMessage]
expectedMsgs]
               exc :: SessionException
exc = FromServerMessage -> [FromServerMessage] -> SessionException
ReplayOutOfOrder FromServerMessage
msg [FromServerMessage]
remainingMsgs
            in IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> SessionException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainThreadId SessionException
exc

  where
  response :: ResponseMessage a -> IO ()
  response :: ResponseMessage a -> IO ()
response ResponseMessage a
res = do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got response for id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspIdRsp -> String
forall a. Show a => a -> String
show (ResponseMessage a
res ResponseMessage a
-> Getting LspIdRsp (ResponseMessage a) LspIdRsp -> LspIdRsp
forall s a. s -> Getting a s a -> a
^. Getting LspIdRsp (ResponseMessage a) LspIdRsp
forall s a. HasId s a => Lens' s a
id)

    MVar LspIdRsp -> LspIdRsp -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LspIdRsp
rspSema (ResponseMessage a
res ResponseMessage a
-> Getting LspIdRsp (ResponseMessage a) LspIdRsp -> LspIdRsp
forall s a. s -> Getting a s a -> a
^. Getting LspIdRsp (ResponseMessage a) LspIdRsp
forall s a. HasId s a => Lens' s a
id) -- unblock the handler waiting to send a request

  request :: RequestMessage ServerMethod a b -> IO ()
  request :: RequestMessage ServerMethod a b -> IO ()
request RequestMessage ServerMethod a b
req = do
    String -> IO ()
putStrLn
      (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
"Got request for id "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ LspId -> String
forall a. Show a => a -> String
show (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting LspId (RequestMessage ServerMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ServerMethod a b) LspId
forall s a. HasId s a => Lens' s a
id)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerMethod -> String
forall a. Show a => a -> String
show (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting
     ServerMethod (RequestMessage ServerMethod a b) ServerMethod
-> ServerMethod
forall s a. s -> Getting a s a -> a
^. Getting ServerMethod (RequestMessage ServerMethod a b) ServerMethod
forall s a. HasMethod s a => Lens' s a
method)

    MVar LspId -> LspId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar LspId
reqSema (RequestMessage ServerMethod a b
req RequestMessage ServerMethod a b
-> Getting LspId (RequestMessage ServerMethod a b) LspId -> LspId
forall s a. s -> Getting a s a -> a
^. Getting LspId (RequestMessage ServerMethod a b) LspId
forall s a. HasId s a => Lens' s a
id) -- unblock the handler waiting for a response

  notification :: NotificationMessage ServerMethod a -> IO ()
  notification :: NotificationMessage ServerMethod a -> IO ()
notification NotificationMessage ServerMethod a
n = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Got notification " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerMethod -> String
forall a. Show a => a -> String
show (NotificationMessage ServerMethod a
n NotificationMessage ServerMethod a
-> Getting
     ServerMethod (NotificationMessage ServerMethod a) ServerMethod
-> ServerMethod
forall s a. s -> Getting a s a -> a
^. Getting
  ServerMethod (NotificationMessage ServerMethod a) ServerMethod
forall s a. HasMethod s a => Lens' s a
method)



-- TODO: QuickCheck tests?
-- | Checks wether or not the message appears in the right order
-- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
-- given N2, notification order doesn't matter.
-- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
-- given REQ1
-- @ N1 N3 N4 N5 REQ2 RES1 @
-- given RES1
-- @ N1 N3 N4 N5 XXXX RES1 @ False!
-- Order of requests and responses matter
inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool

inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
_ [] = String -> Bool
forall a. HasCallStack => String -> a
error String
"Why is this empty"

inRightOrder FromServerMessage
received (FromServerMessage
expected : [FromServerMessage]
msgs)
  | FromServerMessage
received FromServerMessage -> FromServerMessage -> Bool
forall a. Eq a => a -> a -> Bool
== FromServerMessage
expected               = Bool
True
  | FromServerMessage -> Bool
isNotification FromServerMessage
expected            = FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder FromServerMessage
received [FromServerMessage]
msgs
  | Bool
otherwise                          = Bool
False

-- | Ignore logging notifications since they vary from session to session
shouldSkip :: FromServerMessage -> Bool
shouldSkip :: FromServerMessage -> Bool
shouldSkip (NotLogMessage  LogMessageNotification
_) = Bool
True
shouldSkip (NotShowMessage ShowMessageNotification
_) = Bool
True
shouldSkip (ReqShowMessage ShowMessageRequest
_) = Bool
True
shouldSkip FromServerMessage
_                  = Bool
False

-- | Swaps out any commands uniqued with process IDs to match the specified process ID
swapCommands :: Int -> [Event] -> [Event]
swapCommands :: Int -> [Event] -> [Event]
swapCommands Int
_ [] = []

swapCommands Int
pid (FromClient UTCTime
t (ReqExecuteCommand ExecuteCommandRequest
req):[Event]
xs) =  UTCTime -> FromClientMessage -> Event
FromClient UTCTime
t (ExecuteCommandRequest -> FromClientMessage
ReqExecuteCommand ExecuteCommandRequest
swapped)Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs
  where swapped :: ExecuteCommandRequest
swapped = (ExecuteCommandParams -> Identity ExecuteCommandParams)
-> ExecuteCommandRequest -> Identity ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
params ((ExecuteCommandParams -> Identity ExecuteCommandParams)
 -> ExecuteCommandRequest -> Identity ExecuteCommandRequest)
-> ((Text -> Identity Text)
    -> ExecuteCommandParams -> Identity ExecuteCommandParams)
-> (Text -> Identity Text)
-> ExecuteCommandRequest
-> Identity ExecuteCommandRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Identity Text)
-> ExecuteCommandParams -> Identity ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
command ((Text -> Identity Text)
 -> ExecuteCommandRequest -> Identity ExecuteCommandRequest)
-> Text -> ExecuteCommandRequest -> ExecuteCommandRequest
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
newCmd (ExecuteCommandRequest -> ExecuteCommandRequest)
-> ExecuteCommandRequest -> ExecuteCommandRequest
forall a b. (a -> b) -> a -> b
$ ExecuteCommandRequest
req
        newCmd :: Text
newCmd = Int -> Text -> Text
swapPid Int
pid (ExecuteCommandRequest
req ExecuteCommandRequest
-> Getting Text ExecuteCommandRequest Text -> Text
forall s a. s -> Getting a s a -> a
^. (ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> ExecuteCommandRequest -> Const Text ExecuteCommandRequest
forall s a. HasParams s a => Lens' s a
params ((ExecuteCommandParams -> Const Text ExecuteCommandParams)
 -> ExecuteCommandRequest -> Const Text ExecuteCommandRequest)
-> ((Text -> Const Text Text)
    -> ExecuteCommandParams -> Const Text ExecuteCommandParams)
-> Getting Text ExecuteCommandRequest Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> ExecuteCommandParams -> Const Text ExecuteCommandParams
forall s a. HasCommand s a => Lens' s a
command)

swapCommands Int
pid (FromServer UTCTime
t (RspInitialize InitializeResponse
rsp):[Event]
xs) = UTCTime -> FromServerMessage -> Event
FromServer UTCTime
t (InitializeResponse -> FromServerMessage
RspInitialize InitializeResponse
swapped)Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs
  where swapped :: InitializeResponse
swapped = case Maybe (List Text)
newCommands of
          Just List Text
cmds -> (Either ResponseError InitializeResponseCapabilities
 -> Identity (Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse -> Identity InitializeResponse
forall s a. HasResult s a => Lens' s a
result ((Either ResponseError InitializeResponseCapabilities
  -> Identity (Either ResponseError InitializeResponseCapabilities))
 -> InitializeResponse -> Identity InitializeResponse)
-> ((List Text -> Identity (List Text))
    -> Either ResponseError InitializeResponseCapabilities
    -> Identity (Either ResponseError InitializeResponseCapabilities))
-> (List Text -> Identity (List Text))
-> InitializeResponse
-> Identity InitializeResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilities
 -> Identity InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((InitializeResponseCapabilities
  -> Identity InitializeResponseCapabilities)
 -> Either ResponseError InitializeResponseCapabilities
 -> Identity (Either ResponseError InitializeResponseCapabilities))
-> ((List Text -> Identity (List Text))
    -> InitializeResponseCapabilities
    -> Identity InitializeResponseCapabilities)
-> (List Text -> Identity (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Identity (Either ResponseError InitializeResponseCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilitiesInner
 -> Identity InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities ((InitializeResponseCapabilitiesInner
  -> Identity InitializeResponseCapabilitiesInner)
 -> InitializeResponseCapabilities
 -> Identity InitializeResponseCapabilities)
-> ((List Text -> Identity (List Text))
    -> InitializeResponseCapabilitiesInner
    -> Identity InitializeResponseCapabilitiesInner)
-> (List Text -> Identity (List Text))
-> InitializeResponseCapabilities
-> Identity InitializeResponseCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ExecuteCommandOptions
 -> Identity (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner
forall s a. HasExecuteCommandProvider s a => Lens' s a
executeCommandProvider ((Maybe ExecuteCommandOptions
  -> Identity (Maybe ExecuteCommandOptions))
 -> InitializeResponseCapabilitiesInner
 -> Identity InitializeResponseCapabilitiesInner)
-> ((List Text -> Identity (List Text))
    -> Maybe ExecuteCommandOptions
    -> Identity (Maybe ExecuteCommandOptions))
-> (List Text -> Identity (List Text))
-> InitializeResponseCapabilitiesInner
-> Identity InitializeResponseCapabilitiesInner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExecuteCommandOptions -> Identity ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ExecuteCommandOptions -> Identity ExecuteCommandOptions)
 -> Maybe ExecuteCommandOptions
 -> Identity (Maybe ExecuteCommandOptions))
-> ((List Text -> Identity (List Text))
    -> ExecuteCommandOptions -> Identity ExecuteCommandOptions)
-> (List Text -> Identity (List Text))
-> Maybe ExecuteCommandOptions
-> Identity (Maybe ExecuteCommandOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Text -> Identity (List Text))
-> ExecuteCommandOptions -> Identity ExecuteCommandOptions
forall s a. HasCommands s a => Lens' s a
commands ((List Text -> Identity (List Text))
 -> InitializeResponse -> Identity InitializeResponse)
-> List Text -> InitializeResponse -> InitializeResponse
forall s t a b. ASetter s t a b -> b -> s -> t
.~ List Text
cmds (InitializeResponse -> InitializeResponse)
-> InitializeResponse -> InitializeResponse
forall a b. (a -> b) -> a -> b
$ InitializeResponse
rsp
          Maybe (List Text)
Nothing -> InitializeResponse
rsp
        oldCommands :: Maybe (List Text)
oldCommands = InitializeResponse
rsp InitializeResponse
-> Getting (First (List Text)) InitializeResponse (List Text)
-> Maybe (List Text)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Either ResponseError InitializeResponseCapabilities
 -> Const
      (First (List Text))
      (Either ResponseError InitializeResponseCapabilities))
-> InitializeResponse
-> Const (First (List Text)) InitializeResponse
forall s a. HasResult s a => Lens' s a
result ((Either ResponseError InitializeResponseCapabilities
  -> Const
       (First (List Text))
       (Either ResponseError InitializeResponseCapabilities))
 -> InitializeResponse
 -> Const (First (List Text)) InitializeResponse)
-> ((List Text -> Const (First (List Text)) (List Text))
    -> Either ResponseError InitializeResponseCapabilities
    -> Const
         (First (List Text))
         (Either ResponseError InitializeResponseCapabilities))
-> Getting (First (List Text)) InitializeResponse (List Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilities
 -> Const (First (List Text)) InitializeResponseCapabilities)
-> Either ResponseError InitializeResponseCapabilities
-> Const
     (First (List Text))
     (Either ResponseError InitializeResponseCapabilities)
forall c a b. Prism (Either c a) (Either c b) a b
_Right ((InitializeResponseCapabilities
  -> Const (First (List Text)) InitializeResponseCapabilities)
 -> Either ResponseError InitializeResponseCapabilities
 -> Const
      (First (List Text))
      (Either ResponseError InitializeResponseCapabilities))
-> ((List Text -> Const (First (List Text)) (List Text))
    -> InitializeResponseCapabilities
    -> Const (First (List Text)) InitializeResponseCapabilities)
-> (List Text -> Const (First (List Text)) (List Text))
-> Either ResponseError InitializeResponseCapabilities
-> Const
     (First (List Text))
     (Either ResponseError InitializeResponseCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InitializeResponseCapabilitiesInner
 -> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities
forall s a. HasCapabilities s a => Lens' s a
LSP.capabilities ((InitializeResponseCapabilitiesInner
  -> Const (First (List Text)) InitializeResponseCapabilitiesInner)
 -> InitializeResponseCapabilities
 -> Const (First (List Text)) InitializeResponseCapabilities)
-> ((List Text -> Const (First (List Text)) (List Text))
    -> InitializeResponseCapabilitiesInner
    -> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> (List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilities
-> Const (First (List Text)) InitializeResponseCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ExecuteCommandOptions
 -> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner
forall s a. HasExecuteCommandProvider s a => Lens' s a
executeCommandProvider ((Maybe ExecuteCommandOptions
  -> Const (First (List Text)) (Maybe ExecuteCommandOptions))
 -> InitializeResponseCapabilitiesInner
 -> Const (First (List Text)) InitializeResponseCapabilitiesInner)
-> ((List Text -> Const (First (List Text)) (List Text))
    -> Maybe ExecuteCommandOptions
    -> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> (List Text -> Const (First (List Text)) (List Text))
-> InitializeResponseCapabilitiesInner
-> Const (First (List Text)) InitializeResponseCapabilitiesInner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExecuteCommandOptions
 -> Const (First (List Text)) ExecuteCommandOptions)
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((ExecuteCommandOptions
  -> Const (First (List Text)) ExecuteCommandOptions)
 -> Maybe ExecuteCommandOptions
 -> Const (First (List Text)) (Maybe ExecuteCommandOptions))
-> ((List Text -> Const (First (List Text)) (List Text))
    -> ExecuteCommandOptions
    -> Const (First (List Text)) ExecuteCommandOptions)
-> (List Text -> Const (First (List Text)) (List Text))
-> Maybe ExecuteCommandOptions
-> Const (First (List Text)) (Maybe ExecuteCommandOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Text -> Const (First (List Text)) (List Text))
-> ExecuteCommandOptions
-> Const (First (List Text)) ExecuteCommandOptions
forall s a. HasCommands s a => Lens' s a
commands
        newCommands :: Maybe (List Text)
newCommands = (List Text -> List Text) -> Maybe (List Text) -> Maybe (List Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> List Text -> List Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
swapPid Int
pid)) Maybe (List Text)
oldCommands

swapCommands Int
pid (Event
x:[Event]
xs) = Event
xEvent -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:Int -> [Event] -> [Event]
swapCommands Int
pid [Event]
xs

hasPid :: T.Text -> Bool
hasPid :: Text -> Bool
hasPid = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> (Text -> Int) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length (Text -> Int) -> (Text -> Text) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)
swapPid :: Int -> T.Text -> T.Text
swapPid :: Int -> Text -> Text
swapPid Int
pid Text
t
  | Text -> Bool
hasPid Text
t = Text -> Text -> Text
T.append (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
pid) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') Text
t
  | Bool
otherwise = Text
t