packages feed

lsp-test 0.6.0.0 → 0.6.1.0

raw patch · 11 files changed

+131/−60 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Language.Haskell.LSP.Test: NoContentLengthHeader :: SessionException

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.6.1.0 -- 2019-08-24++* Add `satisfyMaybe` (@cocreature)+ ## 0.6.0.0 -- 2019-07-04  * Update to haskell-lsp-0.15.0.0 (@lorenzo)
lsp-test.cabal view
@@ -1,5 +1,5 @@ name:                lsp-test-version:             0.6.0.0+version:             0.6.1.0 synopsis:            Functional test framework for LSP servers. description:   A test framework for writing tests against
src/Language/Haskell/LSP/Test.hs view
@@ -94,7 +94,6 @@ import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap-import Data.IORef import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Types@@ -138,8 +137,6 @@                      -> Session a -- ^ The session to run.                      -> IO a runSessionWithConfig config serverExe caps rootDir session = do-  -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.-  exitOk <- newIORef False   pid <- getCurrentProcessID   absRootDir <- canonicalizePath rootDir @@ -150,9 +147,8 @@                                           caps                                           (Just TraceOff)                                           Nothing-  withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->-    runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do-+  withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->+    runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do       -- Wrap the session around initialize and shutdown calls       initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -160,7 +156,6 @@        initRspVar <- initRsp <$> ask       liftIO $ putMVar initRspVar initRspMsg-       sendNotification Initialized InitializedParams        case lspConfig config of@@ -169,23 +164,14 @@        -- Run the actual test       result <- session--      liftIO $ atomicWriteIORef exitOk True-      sendNotification Exit ExitParams-       return result   where-  catchWhenTrue :: IORef Bool -> IO () -> IO ()-  catchWhenTrue exitOk a =-      a `catch` (\e -> do-          x <- readIORef exitOk-          unless x $ throw (e :: SomeException))+  -- | Asks the server to shutdown and exit politely+  exitServer :: Session ()+  exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams -  -- | Listens to the server output, makes sure it matches the record and-  -- signals any semaphores-  -- Note that on Windows, we cannot kill a thread stuck in getNextMessage.-  -- So we have to wait for the exit notification to kill the process first-  -- and then getNextMessage will fail.+  -- | Listens to the server output until the shutdown ack,+  -- makes sure it matches the record and signals any semaphores   listenServer :: Handle -> SessionContext -> IO ()   listenServer serverOut context = do     msgBytes <- getNextMessage serverOut@@ -195,7 +181,9 @@     let msg = decodeFromServerMsg reqMap msgBytes     writeChan (messageChan context) (ServerMessage msg) -    listenServer serverOut context+    case msg of+      (RspShutdown _) -> return ()+      _               -> listenServer serverOut context  -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text
src/Language/Haskell/LSP/Test/Compat.hs view
@@ -6,14 +6,30 @@ module Language.Haskell.LSP.Test.Compat where  import Data.Maybe+import System.IO  #if MIN_VERSION_process(1,6,3)-import System.Process hiding (getPid)+-- We have to hide cleanupProcess for process-1.6.3.0+-- cause it is in the public api for 1.6.3.0 versions+-- shipped with ghc >= 8.6 and < 8.6.4+import System.Process hiding (getPid, cleanupProcess, withCreateProcess)+# if MIN_VERSION_process(1,6,4)+import qualified System.Process (getPid, cleanupProcess, withCreateProcess)+# else+import Foreign.C.Error+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )+ import qualified System.Process (getPid)+import qualified Control.Exception as C+# endif #else-import System.Process-import System.Process.Internals import Control.Concurrent.MVar+import Foreign.C.Error+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )+import System.Process hiding (withCreateProcess)+import System.Process.Internals++import qualified Control.Exception as C #endif  #ifdef mingw32_HOST_OS@@ -51,4 +67,49 @@       OpenHandle pid -> return $ Just pid #endif       _ -> return Nothing+#endif++cleanupProcess+  :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()++withCreateProcess+  :: CreateProcess+  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)+  -> IO a++#if MIN_VERSION_process(1,6,4)++cleanupProcess = System.Process.cleanupProcess++withCreateProcess = System.Process.withCreateProcess++#else++cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do+    -- We ignore the spurious "permission denied" error in windows:+    --   see https://github.com/haskell/process/issues/110+    ignorePermDenied $ terminateProcess ph+    -- Note, it's important that other threads that might be reading/writing+    -- these handles also get killed off, since otherwise they might be holding+    -- the handle lock and prevent us from closing, leading to deadlock.+    maybe (return ()) (ignoreSigPipe . hClose) mb_stdin+    maybe (return ()) hClose mb_stdout+    maybe (return ()) hClose mb_stderr++    return ()+  where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE+        ignorePermDenied = ignoreIOError PermissionDenied eACCES+    +ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()+ignoreIOError ioErrorType errno =+  C.handle $ \e -> case e of+                     IOError { ioe_type  = iot+                             , ioe_errno = Just ioe }+                       | iot == ioErrorType && Errno ioe == errno -> return ()+                     _ -> C.throwIO e++withCreateProcess c action =+  C.bracket (createProcess c) cleanupProcess+            (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)+ #endif
src/Language/Haskell/LSP/Test/Decoding.hs view
@@ -32,7 +32,7 @@ getNextMessage h = do   headers <- getHeaders h   case read . init <$> lookup "Content-Length" headers of-    Nothing   -> error "Couldn't read Content-Length header"+    Nothing   -> throw NoContentLengthHeader     Just size -> B.hGet h size  addHeader :: B.ByteString -> B.ByteString
src/Language/Haskell/LSP/Test/Exceptions.hs view
@@ -12,6 +12,7 @@  -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' data SessionException = Timeout+                      | NoContentLengthHeader                       | UnexpectedMessage String FromServerMessage                       | ReplayOutOfOrder FromServerMessage [FromServerMessage]                       | UnexpectedDiagnostics@@ -24,6 +25,7 @@  instance Show SessionException where   show Timeout = "Timed out waiting to receive a message from the server."+  show NoContentLengthHeader = "Couldn't read Content-Length header from the server."   show (UnexpectedMessage expected lastMsg) =     "Received an unexpected message from the server:\n" ++     "Was parsing: " ++ expected ++ "\n" ++
src/Language/Haskell/LSP/Test/Parsing.hs view
@@ -24,7 +24,6 @@ import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser-import Data.Maybe import qualified Data.Text as T import Data.Typeable import Language.Haskell.LSP.Messages@@ -65,8 +64,14 @@ -- -- @since 0.5.2.0 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage-satisfy pred = do+satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) +-- | Consumes and returns the result of the specified predicate if it returns `Just`.+--+-- @since 0.6.1.0+satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a+satisfyMaybe pred = do+   skipTimeout <- overridingTimeout <$> get   timeoutId <- curTimeoutId <$> get   unless skipTimeout $ do@@ -83,18 +88,18 @@    modify $ \s -> s { lastReceivedMessage = Just x } -  if pred x-    then do+  case pred x of+    Just a -> do       logMsg LogServer x-      return x-    else empty+      return a+    Nothing -> empty  -- | Matches a message of type @a@. message :: forall a. (Typeable a, FromJSON a) => Session a message =   let parser = decode . encodeMsg :: FromServerMessage -> Maybe a   in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $-    castMsg <$> satisfy (isJust . parser)+     satisfyMaybe parser  -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage@@ -112,17 +117,15 @@ responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do   let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)-  x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)-  return $ castMsg x+  satisfyMaybe $ \msg -> do+    z <- parser msg+    guard (z ^. LSP.id == responseId lid)+    pure z  -- | Matches any type of message. anyMessage :: Session FromServerMessage anyMessage = satisfy (const True) --- | A stupid method for getting out the inner message.-castMsg :: FromJSON a => FromServerMessage -> a-castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg- -- | A version of encode that encodes FromServerMessages as if they -- weren't wrapped. encodeMsg :: FromServerMessage -> B.ByteString@@ -140,8 +143,7 @@ -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' -- (textDocument/publishDiagnostics) notification. publishDiagnosticsNotification :: Session PublishDiagnosticsNotification-publishDiagnosticsNotification = named "Publish diagnostics notification" $ do-  NotPublishDiagnostics diags <- satisfy test-  return diags-  where test (NotPublishDiagnostics _) = True-        test _ = False+publishDiagnosticsNotification = named "Publish diagnostics notification" $+  satisfyMaybe $ \msg -> case msg of+    NotPublishDiagnostics diags -> Just diags+    _ -> Nothing
src/Language/Haskell/LSP/Test/Replay.hs view
@@ -12,7 +12,7 @@ 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 import           Language.Haskell.LSP.Types.Lens as LSP hiding (error) import           Data.Aeson import           Data.Default@@ -23,13 +23,14 @@ 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 +-- | 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".@@ -43,8 +44,9 @@   -- decode session   let unswappedEvents = map (fromJust . decode) entries -  withServer serverExe False $ \serverIn serverOut pid -> do+  withServer serverExe False $ \serverIn serverOut serverProc -> do +    pid <- getProcessID serverProc     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents      let clientEvents = filter isClientMsg events@@ -59,12 +61,12 @@     mainThread <- myThreadId      sessionThread <- liftIO $ forkIO $-      runSessionWithHandles serverIn-                            serverOut+      runSessionWithHandles serverIn serverOut serverProc                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)                             def                             fullCaps                             sessionDir+                            (return ()) -- No finalizer cleanup                             (sendMessages clientMsgs reqSema rspSema)     takeMVar passSema     killThread sessionThread
src/Language/Haskell/LSP/Test/Server.hs view
@@ -4,9 +4,9 @@ import Control.Monad import Language.Haskell.LSP.Test.Compat import System.IO-import System.Process+import System.Process hiding (withCreateProcess) -withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a+withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a withServer serverExe logStdErr f = do   -- TODO Probably should just change runServer to accept   -- separate command and arguments@@ -19,5 +19,4 @@     hSetBinaryMode serverErr True     let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn     withAsync errSinkThread $ \_ -> do-      pid <- getProcessID serverProc-      f serverIn serverOut pid+      f serverIn serverOut serverProc
src/Language/Haskell/LSP/Test/Session.hs view
@@ -60,11 +60,14 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding (error) import Language.Haskell.LSP.VFS+import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions import System.Console.ANSI import System.Directory import System.IO+import System.Process (ProcessHandle())+import System.Timeout  -- | A session representing one instance of launching and connecting to a server. --@@ -186,13 +189,15 @@ -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in                       -> Handle -- ^ Server out+                      -> ProcessHandle -- ^ Server process                       -> (Handle -> SessionContext -> IO ()) -- ^ Server listener                       -> SessionConfig                       -> ClientCapabilities                       -> FilePath -- ^ Root directory+                      -> Session () -- ^ To exit the Server properly                       -> Session a                       -> IO a-runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do+runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do   absRootDir <- canonicalizePath rootDir    hSetBuffering serverIn  NoBuffering@@ -210,11 +215,19 @@    let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps       initState = SessionState (IdInt 0) mempty mempty 0 False Nothing-      launchServerHandler = forkIO $ catch (serverHandler serverOut context)-                                           (throwTo mainThreadId :: SessionException -> IO ())-  (result, _) <- bracket launchServerHandler killThread $-    const $ runSession context initState session+      runSession' = runSession context initState +      errorHandler = throwTo mainThreadId :: SessionException -> IO()+      serverListenerLauncher =+        forkIO $ catch (serverHandler serverOut context) errorHandler+      server = (Just serverIn, Just serverOut, Nothing, serverProc)+      serverAndListenerFinalizer tid =+        finally (timeout (messageTimeout config * 1000000)+                         (runSession' exitServer))+                (cleanupProcess server >> killThread tid)++  (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer+                         (const $ runSession' session)   return result  updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
test/Test.hs view
@@ -104,7 +104,7 @@        it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do         loggingNotification-        liftIO $ threadDelay 10+        liftIO $ threadDelay $ 10 * 1000000         _ <- openDoc "Desktop/simple.hs" "haskell"         return ()