import Prelude hiding (id)
import Control.Concurrent
+import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.Text as T
+import Data.UUID
import Language.Haskell.LSP.Capture
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types hiding (error)
import Data.Aeson
import Data.List
import Data.Maybe
-import Control.Lens
+import Control.Lens hiding (List)
import Control.Monad
import System.IO
import System.FilePath
+import System.Random
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Test.Files
import Language.Haskell.LSP.Test.Decoding
import Language.Haskell.LSP.Test.Messages
+import Language.Haskell.LSP.Test.Server
-- | 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".
-replaySession :: FilePath -- ^ The filepath to the server executable.
+replaySession :: String -- ^ The command to run the server.
-> FilePath -- ^ The recorded session directory.
-> IO Bool
replaySession serverExe sessionDir = do
-- decode session
let unswappedEvents = map (fromJust . decode) entries
- events <- swapFiles sessionDir unswappedEvents
+ withServer serverExe $ \serverIn serverOut pid -> do
+
+ events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents
let clientEvents = filter isClientMsg events
serverEvents = filter isServerMsg events
passVar <- newEmptyMVar :: IO (MVar Bool)
threadId <- forkIO $
- runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
- serverExe
+ runSessionWithHandles serverIn
+ serverOut
+ (listenServer serverMsgs requestMap reqSema rspSema passVar)
sessionDir
(sendMessages clientMsgs reqSema rspSema)
listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
- msgBytes <- liftIO $ getNextMessage serverOut
+
+ let handler :: IOException -> IO B.ByteString
+ handler _ = putMVar passVar False >> return B.empty
+
+ msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
let msg = decodeFromServerMsg reqMap msgBytes
handleServerMessage request response notification msg
shouldSkip (NotShowMessage _) = True
shouldSkip (ReqShowMessage _) = True
shouldSkip _ = False
+
+-- | Swaps out the expected UUIDs to match the current process ID
+swapUUIDs :: Int -> [Event] -> [Event]
+swapUUIDs _ [] = []
+swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs
+ where swapped = case newCommands of
+ Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
+ Nothing -> rsp
+ oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
+ newCommands = fmap (fmap swap) oldCommands
+ swap cmd
+ | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd
+ | otherwise = cmd
+ uuid = toText $ fst $ random $ mkStdGen pid
+ isUuid = isJust . fromText . T.takeWhile (/= ':')
+swapUUIDs pid (x:xs) = x:swapUUIDs pid xs
\ No newline at end of file