Merge pull request #39 from well-typed/edsko/early-termination-bug

Early termination bugs

.github/workflows/haskell-ci.yml

@@ -160,6 +160,11 @@ jobs:
           echo "package grapesy" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
+          source-repository-package
+            type:     git
+            location: https://github.com/edsko/http2.git
+            tag:      c2a2994ed45a08998c2b6eb22a08f28b9eb36c3c
+
           package grapesy
             tests:       True
             flags:       +build-demo +build-stress-test

cabal.project

@@ -4,7 +4,9 @@ package grapesy
   tests: True
   flags: +build-demo +build-stress-test
 
+-- The version on Hackage also works, it just writes some (unnecessary)
+-- exceptions to stderr
 source-repository-package
   type: git
   location: https://github.com/edsko/http2.git
-  tag: f093214cba22ee90408f2d3c44d995ddbddd5766 
+  tag: c2a2994ed45a08998c2b6eb22a08f28b9eb36c3c

cabal.project.ci

@@ -4,3 +4,8 @@ package grapesy
   tests: True
   flags: +build-demo +build-stress-test
   ghc-options: -Werror
+
+source-repository-package
+  type: git
+  location: https://github.com/edsko/http2.git
+  tag: c2a2994ed45a08998c2b6eb22a08f28b9eb36c3c

test-common/Test/Util/ClientServer.hs

@@ -349,7 +349,7 @@ runTestServer cfg serverExceptions serverTracer handlerLock serverHandlers = do
 runTestClient :: forall a.
      ClientServerConfig
   -> Tracer IO Client.ClientDebugMsg
-  -> (Client.Connection -> IO a)
+  -> ((forall b. (Client.Connection -> IO b) -> IO b) -> IO a)
   -> IO a
 runTestClient cfg clientTracer clientRun = do
     pubCert <- getDataFileName "grpc-demo.cert"
@@ -415,16 +415,15 @@ runTestClient cfg clientTracer clientRun = do
                 , authorityPort = 50051
                 }
 
-    Client.withConnection clientParams clientServer $ \conn ->
-      clientRun conn
+    clientRun $ Client.withConnection clientParams clientServer
 
 {-------------------------------------------------------------------------------
   Main entry point: run server and client together
 -------------------------------------------------------------------------------}
 
 runTestClientServer :: forall a.
      ClientServerConfig
-  -> (Client.Connection -> IO a)
+  -> ((forall b. (Client.Connection -> IO b) -> IO b) -> IO a)
   -> [Server.RpcHandler IO]
   -> IO a
 runTestClientServer cfg clientRun serverHandlers = do

test-grapesy/Test/Driver/ClientServer.hs

@@ -27,7 +27,7 @@ import Text.Show.Pretty
 
 data ClientServerTest = ClientServerTest {
       config :: ClientServerConfig
-    , client :: Client.Connection -> IO ()
+    , client :: (forall a. (Client.Connection -> IO a) -> IO a) -> IO ()
     , server :: [Server.RpcHandler IO]
     }
 

test-grapesy/Test/Driver/Dialogue/Definition.hs

@@ -14,6 +14,8 @@ module Test.Driver.Dialogue.Definition (
   , ExceptionId(..)
     -- ** Wrappers
   , AnnotatedServerException(..)
+    -- * Utility
+  , hasEarlyTermination
   ) where
 
 import Control.Exception
@@ -57,7 +59,7 @@ data Action a b =
     -- | Send a message to the peer
   | Send (StreamElem b Int)
 
-    -- | Terminate (cleanly or with an exception)
+    -- | Early termination (cleanly or with an exception)
   | Terminate (Maybe ExceptionId)
 
     -- | Sleep specified number of milliseconds
@@ -134,3 +136,19 @@ data AnnotatedServerException = AnnotatedServerException {
   deriving anyclass (Exception, PrettyVal)
   deriving Show via ShowAsPretty AnnotatedServerException
 
+{-------------------------------------------------------------------------------
+  Utility
+-------------------------------------------------------------------------------}
+
+hasEarlyTermination :: GlobalSteps -> Bool
+hasEarlyTermination =
+      any isEarlyTermination
+    . map snd
+    . concatMap getLocalSteps
+    . getGlobalSteps
+  where
+    isEarlyTermination :: LocalStep -> Bool
+    isEarlyTermination (ClientAction (Terminate _)) = True
+    isEarlyTermination (ServerAction (Terminate _)) = True
+    isEarlyTermination _                            = False
+

test-grapesy/Test/Driver/Dialogue/Execution.hs

@@ -13,6 +13,7 @@ import Control.Monad.State
 import Data.Bifunctor
 import Data.Default
 import Data.List (sortBy)
+import Data.Maybe (mapMaybe)
 import Data.Ord (comparing)
 import Data.Proxy
 import Data.Set qualified as Set
@@ -150,7 +151,17 @@ clientLocal testClock call = \(LocalSteps steps) ->
             continue <-   clientAct action
                         `finally`
                           liftIO (advanceTestClock testClock)
-            when continue $ go steps
+            if continue then
+              go steps
+            else do
+              -- See discussion in serverLocal
+              let ourStep :: (TestClockTick, LocalStep) -> Maybe TestClockTick
+                  ourStep (tick' , ClientAction _) = Just tick'
+                  ourStep (_     , ServerAction _) = Nothing
+              liftIO $ do
+                void $ forkIO $
+                  advanceTestClockAtTimes testClock $
+                    mapMaybe ourStep steps
           ServerAction action -> do
             reactToServer action
             go steps
@@ -168,21 +179,10 @@ clientLocal testClock call = \(LocalSteps steps) ->
         Send x -> do
           isExpected <- adjustExpectation ()
           expect isExpected =<< liftIO (try $ Client.Binary.sendInput call x)
-
-          -- This is making a difference:  we see an extra frame, that is
-          -- termating the stream. However, the server recvMessageLoop for some
-          -- reason is not receiving it. I don't know why.
-          --
-          -- Without this, we see GO_AWAY instead, which i guess on the server
-          -- side is killing the handler, without it getting a chance to
-          -- intercept it. At this point, recvMessageLoop will die because the
-          -- call to getChunk is blocked indefinitely.
           return True
         Terminate (Just exceptionId) -> do
           throwM $ SomeClientException exceptionId
         Terminate Nothing ->
-          -- This is a sign to the server that the client will terminate; we
-          -- don't have to do anything here.
           return False
         SleepMilli n -> do
           liftIO $ threadDelay (n * 1_000)
@@ -255,23 +255,41 @@ clientLocal testClock call = \(LocalSteps steps) ->
                  Right x'   -> x == x'
                  _otherwise -> False
 
-clientGlobal :: TestClock -> Client.Connection -> GlobalSteps -> IO ()
-clientGlobal testClock conn = \(GlobalSteps globalSteps) ->
-    go [] globalSteps
+clientGlobal ::
+     TestClock
+  -> (forall a. (Client.Connection -> IO a) -> IO a)
+  -> GlobalSteps
+  -> IO ()
+clientGlobal testClock withConn = \steps@(GlobalSteps globalSteps) ->
+    -- TODO: The tests assume that different calls are independent from each
+    -- other. This is mostly true, but not completely: when a client or a server
+    -- terminates early, the entire connection (supporting potentially many
+    -- calls) is reset. It's not entirely clear why; it feels like an
+    -- unnecessary limitation in @http2@.
+    --
+    -- Ideally, we would either (1) randomly assign connections to calls and
+    -- then test that an early termination only affects calls using the same
+    -- connection, or better yet, (2), remove this limitation from @http2@.
+    --
+    -- For now, we do neither: /if/ a test includes early termination, we give
+    -- each call its own connection, thereby regaining independence.
+    if hasEarlyTermination steps
+      then go Nothing [] globalSteps
+      else withConn $ \conn -> go (Just conn) [] globalSteps
   where
-    go :: [Async ()] -> [LocalSteps] -> IO ()
-    go threads [] = do
+    go :: Maybe Client.Connection -> [Async ()] -> [LocalSteps] -> IO ()
+    go _ threads [] = do
          -- Wait for all threads to finish
          --
          -- This also ensures that if any of these threads threw an exception,
          -- that is now rethrown here in the main test.
         mapM_ wait threads
-    go threads (c:cs) =
-        withAsync (runLocalSteps c) $ \newThread ->
-          go (newThread:threads) cs
+    go mConn threads (c:cs) =
+        withAsync (runLocalSteps mConn c) $ \newThread ->
+          go mConn (newThread:threads) cs
 
-    runLocalSteps :: LocalSteps -> IO ()
-    runLocalSteps (LocalSteps steps) = do
+    runLocalSteps :: Maybe Client.Connection -> LocalSteps -> IO ()
+    runLocalSteps mConn (LocalSteps steps) = do
         case steps of
           (tick, ClientAction (Initiate (metadata, rpc))) : steps' -> do
             waitForTestClockTick testClock tick
@@ -286,18 +304,21 @@ clientGlobal testClock conn = \(GlobalSteps globalSteps) ->
                   }
 
             withProxy rpc $ \proxy ->
-              Client.withRPC conn params proxy $ \call -> do
-                -- We wait for the /server/ to advance the test clock (so that
-                -- we are use the next step doesn't happen until the connection
-                -- is established).
-                --
-                -- NOTE: We could instead wait for the server to send the
-                -- initial metadata; this too would provide evidence that the
-                -- conneciton has been established. However, doing so precludes
-                -- a class of correct behaviour: the server might not respond
-                -- with that initial metadata until the client has sent some
-                -- messages.
-                clientLocal testClock call (LocalSteps steps')
+              (case mConn of
+                  Just conn -> ($ conn)
+                  Nothing   -> withConn) $ \conn ->
+                Client.withRPC conn params proxy $ \call -> do
+                  -- We wait for the /server/ to advance the test clock (so that
+                  -- we are use the next step doesn't happen until the connection
+                  -- is established).
+                  --
+                  -- NOTE: We could instead wait for the server to send the
+                  -- initial metadata; this too would provide evidence that the
+                  -- conneciton has been established. However, doing so precludes
+                  -- a class of correct behaviour: the server might not respond
+                  -- with that initial metadata until the client has sent some
+                  -- messages.
+                  clientLocal testClock call (LocalSteps steps')
 
           _otherwise ->
             error $ "clientGlobal: expected Initiate, got " ++ show steps
@@ -367,7 +388,19 @@ serverLocal testClock call = \(LocalSteps steps) -> do
             continue <-   serverAct action
                         `finally`
                           liftIO (advanceTestClock testClock)
-            when continue $ go steps
+            if continue then
+              go steps
+            else do
+              -- We need to exit the scope of the handler, but we do want to
+              -- keep advancing the test clock when its our turn, so that we
+              -- don't interfere with the timing of other threads.
+              let ourStep :: (TestClockTick, LocalStep) -> Maybe TestClockTick
+                  ourStep (tick' , ServerAction _) = Just tick'
+                  ourStep (_     , ClientAction _) = Nothing
+              liftIO $ do
+                void $ forkIO $
+                  advanceTestClockAtTimes testClock $
+                    mapMaybe ourStep steps
           ClientAction action -> do
             reactToClient action
             go steps
@@ -393,7 +426,6 @@ serverLocal testClock call = \(LocalSteps steps) -> do
         Terminate (Just exceptionId) -> do
           throwM $ SomeServerException exceptionId
         Terminate Nothing ->
-          -- Nothing to do; this is simply the last instruction we execute
           return False
         SleepMilli n -> do
           liftIO $ threadDelay (n * 1_000)

test-grapesy/Test/Driver/Dialogue/Generation.hs

@@ -122,8 +122,6 @@ genLocalSteps genExceptions = sized $ \sz -> do
 data LocalGenState = LocalGenState {
       clientInitiatedRequest  :: Bool
     , serverInitiatedResponse :: Bool
-    , clientSentFinalMessage  :: Bool
-    , serverSentFinalMessage  :: Bool
     , clientTerminated        :: Bool
     , serverTerminated        :: Bool
     }
@@ -132,8 +130,6 @@ initLocalGenState :: LocalGenState
 initLocalGenState = LocalGenState {
       clientInitiatedRequest  = False
     , serverInitiatedResponse = False
-    , clientSentFinalMessage  = False
-    , serverSentFinalMessage  = False
     , clientTerminated        = False
     , serverTerminated        = False
     }
@@ -184,14 +180,11 @@ ensureCorrectUsage = go Map.empty []
 
               -- Make sure no messages are sent after the final one
 
-              Send{} | clientSentFinalMessage st ->
-                go sts acc ss
-
               Send StreamElem{} ->
                 go sts ((i, s) : acc) ss
 
               Send{} ->
-                go (upd st{clientSentFinalMessage = True}) ((i, s) : acc) ss
+                go (upd st{clientTerminated = True}) ((i, s) : acc) ss
 
               -- Unless we terminated or have not yet started the request the
               -- client, we can always sleep.
@@ -231,14 +224,11 @@ ensureCorrectUsage = go Map.empty []
 
               -- Make sure no messages are sent after the final one
 
-              Send{} | serverSentFinalMessage st ->
-                go sts acc ss
-
               Send StreamElem{} ->
                 go sts ((i, s) : acc) ss
 
               Send{} ->
-                go (upd st{serverSentFinalMessage = True}) ((i, s) : acc) ss
+                go (upd st{serverTerminated = True}) ((i, s) : acc) ss
 
               -- Unless we terminated or have not yet started the request the
               -- client, we can always sleep.
@@ -257,13 +247,11 @@ ensureCorrectUsage = go Map.empty []
     ensureCleanClose st = concat [
           [ ClientAction $ Send $ NoMoreElems NoMetadata
           | clientInitiatedRequest st
-          , not $ clientSentFinalMessage st
           , not $ clientTerminated st
           ]
 
         , [ ServerAction $ Send $ NoMoreElems Set.empty
           | clientInitiatedRequest st
-          , not $ serverSentFinalMessage st
           , not $ serverTerminated st
           ]
         ]

test-grapesy/Test/Driver/Dialogue/TestClock.hs

@@ -5,6 +5,8 @@ module Test.Driver.Dialogue.TestClock (
   , newTestClock
   , waitForTestClockTick
   , advanceTestClock
+  , advanceTestClockAtTime
+  , advanceTestClockAtTimes
     -- * Interleavings
   , interleave
   , assignTimings
@@ -62,6 +64,14 @@ waitForTestClockTick (TestClock clock) tick = do
 advanceTestClock :: TestClock -> IO ()
 advanceTestClock (TestClock clock) = atomically (modifyTVar clock succ)
 
+advanceTestClockAtTime :: TestClock -> TestClockTick -> IO ()
+advanceTestClockAtTime clock tick = do
+    waitForTestClockTick clock tick
+    advanceTestClock clock
+
+advanceTestClockAtTimes :: TestClock -> [TestClockTick] -> IO ()
+advanceTestClockAtTimes = mapM_ . advanceTestClockAtTime
+
 {-------------------------------------------------------------------------------
   Interleavings
 

test-grapesy/Test/Prop/Dialogue.hs

@@ -34,6 +34,7 @@ tests = testGroup "Test.Prop.Dialogue" [
         , testCaseInfo "earlyTermination2" $ regression earlyTermination2
         , testCaseInfo "earlyTermination3" $ regression earlyTermination3
         , testCaseInfo "earlyTermination4" $ regression earlyTermination4
+        , testCaseInfo "earlyTermination5" $ regression earlyTermination5
         ]
     , testGroup "Setup" [
           testProperty "shrinkingWellFounded" prop_shrinkingWellFounded
@@ -309,3 +310,16 @@ earlyTermination4 = Dialogue [
     , (0, ClientAction $ Send (NoMoreElems NoMetadata))
     , (0, ServerAction $ Send (NoMoreElems (Set.fromList [])))
     ]
+
+-- Test that early termination in one call does not affect the other. This is
+-- currently /only/ true if they use separate connections; see discussion in
+-- 'clientGlobal'.
+earlyTermination5 :: Dialogue
+earlyTermination5 = Dialogue [
+      (1, ClientAction $ Initiate (Set.fromList [],RPC1))
+    , (1, ServerAction $ Terminate Nothing)
+    , (0, ClientAction $ Initiate (Set.fromList [],RPC1))
+    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
+    , (0, ServerAction $ Send (NoMoreElems (Set.fromList [])))
+    , (1, ClientAction $ Send (NoMoreElems NoMetadata))
+    ]