Dialogue.hs

{-# LANGUAGE OverloadedStrings #-}

module Test.Prop.Dialogue (tests) where

import Control.Exception
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

import Network.GRPC.Common

import Test.Driver.ClientServer
import Test.Driver.Dialogue

tests :: TestTree
tests = testGroup "Test.Prop.Dialogue" [
      testGroup "Regression" [
          testCase "trivial1"               $ regression SharedConn trivial1
        , testCase "trivial2"               $ regression SharedConn trivial2
        , testCase "trivial3"               $ regression SharedConn trivial3
        , testCase "concurrent1"            $ regression SharedConn concurrent1
        , testCase "concurrent2"            $ regression SharedConn concurrent2
        , testCase "concurrent3"            $ regression SharedConn concurrent3
        , testCase "concurrent4"            $ regression SharedConn concurrent4
        , testCase "exception1"             $ regression ConnPerRPC exception1
        , testCase "exception2"             $ regression ConnPerRPC exception2
        , testCase "earlyTermination01"     $ regression ConnPerRPC earlyTermination01
        , testCase "earlyTermination02"     $ regression ConnPerRPC earlyTermination02
        , testCase "earlyTermination03"     $ regression ConnPerRPC earlyTermination03
        , testCase "earlyTermination04"     $ regression ConnPerRPC earlyTermination04
        , testCase "earlyTermination05"     $ regression ConnPerRPC earlyTermination05
        , testCase "earlyTermination06"     $ regression ConnPerRPC earlyTermination06
        , testCase "earlyTermination07"     $ regression ConnPerRPC earlyTermination07
        , testCase "earlyTermination08"     $ regression ConnPerRPC earlyTermination08
        , testCase "earlyTermination09"     $ regression ConnPerRPC earlyTermination09
        , testCase "earlyTermination10"     $ regression ConnPerRPC earlyTermination10
        , testCase "earlyTermination11"     $ regression ConnPerRPC earlyTermination11
        , testCase "earlyTermination12"     $ regression ConnPerRPC earlyTermination12
        , testCase "earlyTermination13"     $ regression ConnPerRPC earlyTermination13
        , testCase "earlyTermination14"     $ regression ConnPerRPC earlyTermination14
        , testCase "unilateralTermination1" $ regression SharedConn unilateralTermination1
        , testCase "unilateralTermination2" $ regression SharedConn unilateralTermination2
        , testCase "unilateralTermination3" $ regression SharedConn unilateralTermination3
        , testCase "allowHalfClosed1"       $ regression SharedConn allowHalfClosed1
        , testCase "allowHalfClosed2"       $ regression SharedConn allowHalfClosed2
        , testCase "allowHalfClosed3"       $ regression ConnPerRPC allowHalfClosed3
        ]
    , testGroup "Setup" [
          testProperty "shrinkingWellFounded" prop_shrinkingWellFounded
        ]
    , testGroup "Arbitrary" [
          testGroup "WithoutExceptions" [
            testProperty "connPerRPC" $ arbitraryWithoutExceptions ConnPerRPC
          , testProperty "sharedConn" $ arbitraryWithoutExceptions SharedConn
          ]
        , testGroup "WithExceptions" [
            testProperty "connPerRPC" $ arbitraryWithExceptions ConnPerRPC
          , testProperty "sharedConn" $ arbitraryWithExceptions SharedConn
          ]
        ]
    ]

{-------------------------------------------------------------------------------
  Verify setup is correct
-------------------------------------------------------------------------------}

prop_shrinkingWellFounded :: Property
prop_shrinkingWellFounded =
    -- Explicit 'forAll' so that we can disable shrinking here
    -- (If shrinking is /not/ well-founded, then we should not try to shrink!)
    forAll arbitrary $ \(d :: DialogueWithoutExceptions) ->
      d `notElem` shrink d

{-------------------------------------------------------------------------------
  Running the tests
-------------------------------------------------------------------------------}

arbitraryWithoutExceptions :: ConnUsage -> DialogueWithoutExceptions -> Property
arbitraryWithoutExceptions connUsage (DialogueWithoutExceptions dialogue) =
    propDialogue connUsage dialogue

arbitraryWithExceptions :: ConnUsage -> DialogueWithExceptions -> Property
arbitraryWithExceptions connUsage (DialogueWithExceptions dialogue) =
    propDialogue connUsage dialogue

propDialogue :: ConnUsage -> Dialogue -> Property
propDialogue connUsage dialogue =
    counterexample (show globalSteps) $
      propClientServer $ execGlobalSteps connUsage globalSteps
  where
    globalSteps :: GlobalSteps
    globalSteps = dialogueGlobalSteps dialogue

regression :: ConnUsage -> Dialogue -> IO ()
regression connUsage dialogue =
    handle (throwIO . RegressionTestFailed globalSteps) $
      testClientServer =<< execGlobalSteps connUsage globalSteps
  where
    globalSteps :: GlobalSteps
    globalSteps = dialogueGlobalSteps dialogue

data RegressionTestFailed = RegressionTestFailed {
      regressionGlobalSteps :: GlobalSteps
    , regressionException   :: SomeException
    }
  deriving stock (Show)
  deriving anyclass (Exception)

{-------------------------------------------------------------------------------
  Regression tests

  We use only 'NormalizedDialogue' here, so that /if/ we change normalization
  (because some additional invariant needs to be preserved, for example), we
  will get a useful test failure indicating which tests need to be adjusted.
-------------------------------------------------------------------------------}

-- | Sanity check: server tells client immediately that there is nothing to say
--
-- One of the things this test verifies (apart from the testing infrastructure
-- itself) is that the server gets the chance to terminate cleanly.
trivial1 :: Dialogue
trivial1 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Variation on 'trivial1' where the client sends a message before the
-- server closed the call
trivial2 :: Dialogue
trivial2 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (StreamElem 1234))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Variation on 'trivial1' where the server closes the call unilaterally
trivial3 :: Dialogue
trivial3 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Verify that the test infrastructure does not confuse client/server threads
--
-- It's trickier than one might think to make sure that the server handler and
-- a client agree on a set of steps to execute. This test, along with
-- 'concurrent2' and 'concurrent3', and sanity checks to make sure that this
-- goes well.
concurrent1 :: Dialogue
concurrent1 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (1, ClientAction $ Initiate (def, RPC1))
    , (1, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    , (1, ServerAction $ Send (NoMoreElems def))
    ]

concurrent2 :: Dialogue
concurrent2 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def, RPC1))
    , (1, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    , (1, ServerAction $ Send (NoMoreElems def))
    ]

concurrent3 :: Dialogue
concurrent3 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def{metadataAsc2 = Just "b"}, RPC1))
    , (0, ClientAction $ Initiate (def{metadataAsc1 = Just "a"}, RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    , (1, ClientAction $ Send (NoMoreElems NoMetadata))
    , (1, ServerAction $ Send (NoMoreElems def))
    ]

-- | Test that the final message is received
--
-- See also <https://github.com/kazu-yamamoto/http2/issues/86>.
concurrent4 :: Dialogue
concurrent4 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def, RPC1))
    , (1, ClientAction $ Send (FinalElem 1 NoMetadata))
    , (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (FinalElem 2 NoMetadata))
    , (1, ServerAction $ Send (FinalElem 3 def))
    , (0, ServerAction $ Send (FinalElem 4 def))
    ]

-- | Server-side exception
--
-- Since the handler throws an exception without sending /anything/, the
-- exception will be reported to the client using the gRPC trailers-only case.
-- This test also verifies that the client can /receive/ this message
exception1 :: Dialogue
exception1 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Terminate (Just $ SomeServerException 0))
    ]

-- | Client-side exception
exception2 :: Dialogue
exception2 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Server handler terminates before the client expects it
earlyTermination01 :: Dialogue
earlyTermination01 = NormalizedDialogue [
      (0, ClientAction (Initiate (def, RPC1)))
    , (0, ServerAction (Terminate Nothing))
    ]

-- | Client terminates before the server handler expects it
earlyTermination02 :: Dialogue
earlyTermination02 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Terminate Nothing)
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Variation on early client-side termination that tends to trigger a
-- different code path, where we get a stream error; in @grapesy@ these
-- various kinds of exceptions we can get from @http2@ should all be reported
-- in the same manner (as 'ClientDisconnected' exceptions).
earlyTermination03 :: Dialogue
earlyTermination03 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def, RPC1 ))
    , (0, ClientAction $ Initiate (def, RPC1))
    , (1, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (1, ServerAction $ Send (NoMoreElems def))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Another minor variation on 'earlyTermination03', which tends to trigger yet
-- another codepath
earlyTermination04 :: Dialogue
earlyTermination04 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (1, ClientAction $ Initiate (def, RPC1 ))
    , (1, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (1, ServerAction $ Send (NoMoreElems def))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- 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'.
earlyTermination05 :: Dialogue
earlyTermination05 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def,RPC1))
    , (1, ServerAction $ Terminate Nothing)
    , (0, ClientAction $ Initiate (def,RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Variation where the client does send some messages before throwing an
-- exception
--
-- This is mostly a check on the test infrastructure itself. In a test case
-- like this where a message is enqueued and then an exception is thrown, the
-- exception might " overtake " that message and the server will never
-- receive it. This motivates the " conservative " test mode where we test
-- each operation in a synchronous manner.
earlyTermination06 :: Dialogue
earlyTermination06 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (StreamElem 0))
    , (0, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Server-side early termination
earlyTermination07 :: Dialogue
earlyTermination07 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (0, ServerAction $ Terminate (Just (SomeServerException 0)))
    ]

-- | Server-side early termination, Trailers-Only case
--
-- This is like 'earlyTermination07', but in this case the server does not send
-- the initial metadata, which causes the server handler to use the gRPC
-- Trailers-Only case to send the error to the client.
earlyTermination08 :: Dialogue
earlyTermination08 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Terminate (Just (SomeServerException 0)))
    ]

-- | Like 'earlyTermination07', but now without an exception
earlyTermination09 :: Dialogue
earlyTermination09 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (0, ServerAction $ Terminate Nothing)
    ]

-- | Client throws after the server sends their initial metadata
earlyTermination10 :: Dialogue
earlyTermination10 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (0, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Like 'earlyTermination10', but server sends a message before closing
earlyTermination11 :: Dialogue
earlyTermination11 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (0, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ServerAction $ Send (StreamElem 0))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Client tries to send message but server has already terminated
--
-- This gets sandwiched between another interaction with no unexpected early
-- termination.
--
-- This is a test of the test suite itself: it verifies that we step the test
-- clock correctly in the presence of failures.
earlyTermination12 :: Dialogue
earlyTermination12 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC2))
    , (1, ClientAction $ Initiate (def, RPC1))
    , (1, ServerAction $ Terminate Nothing)
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Like earlyTermination12, but the sandwich the other way around
--
-- We also send more messages; this is mostly testing the test infrastructure
-- itself (specifically, that the test clock is used correctly).
earlyTermination13 :: Dialogue
earlyTermination13 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Send (StreamElem 1))
    , (0, ServerAction $ Send (StreamElem 2))
    , (1, ClientAction $ Initiate (def, RPC1))
    , (1, ServerAction $ Send (NoMoreElems def))
    , (0, ServerAction $ Send (StreamElem 3))
    , (0, ServerAction $ Terminate (Just (SomeServerException 0)))
    ]

-- | Both the server /and/ the client terminate early
--
-- This is primarily a test of the test infrastructure itself: after the client
-- has terminated, it can no longer green-light the server.
earlyTermination14 :: Dialogue
earlyTermination14 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Terminate Nothing)
    , (0, ServerAction $ Terminate (Just (SomeServerException 0)))
    ]

unilateralTermination1 :: Dialogue
unilateralTermination1 = NormalizedDialogue [
      (1,ClientAction (Initiate (def,RPC1)))
    , (1,ServerAction (Send (FinalElem 0 def)))
    , (0,ClientAction (Initiate (def,RPC1)))
    , (0,ClientAction (Send (NoMoreElems NoMetadata)))
    , (0,ServerAction (Send (NoMoreElems def)))
    ]

unilateralTermination2 :: Dialogue
unilateralTermination2 = NormalizedDialogue [
      (1,ClientAction (Initiate (def,RPC1)))
    , (1,ServerAction (Send (FinalElem 0 def)))
    , (0,ClientAction (Initiate (def,RPC1)))
    , (0,ClientAction (Send (NoMoreElems NoMetadata)))
    , (0,ServerAction (Send (NoMoreElems def)))
    , (2,ClientAction (Initiate (def,RPC1)))
    , (2,ServerAction (Send (FinalElem 0 def)))
    ]

unilateralTermination3 :: Dialogue
unilateralTermination3 = NormalizedDialogue [
      (0, ClientAction (Initiate (def,RPC1)))
    , (0, ServerAction (Send (NoMoreElems def)))
    , (1, ClientAction (Initiate (def,RPC1)))
    , (1, ClientAction (Send (FinalElem 0 NoMetadata)))
    , (1, ServerAction (Send (NoMoreElems def)))
    ]

{-------------------------------------------------------------------------------
  Dealing correctly with 'AllowHalfClosed'

  NOTE: Once the client puts the connection in half-closed state, if it then
  subsequently crashes, the server may not notice as it is not listening for
  messages from the client anymore (it may notice it when it sends, though).
  For this reason we rule out test cases in which the client terminates "early"
  after having already put the connection in half-closed mode.
-------------------------------------------------------------------------------}

-- | We close the outbound stream in the client
--
-- This was previously causing the connection to break; see 'NoTrailers' for
-- detailed discussion.
allowHalfClosed1 :: Dialogue
allowHalfClosed1 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def, RPC1))
    , (1, ServerAction $ Send (NoMoreElems def))
    , (0, ClientAction $ Initiate (def, RPC1))
    , (0, ServerAction $ Initiate def)
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Variation on 'allowHalfClosed1' without an explicit server initiation.
allowHalfClosed2 :: Dialogue
allowHalfClosed2 = NormalizedDialogue [
      (1, ClientAction $ Initiate (def, RPC1))
    , (1, ServerAction $ Send (NoMoreElems def))
    , (0, ClientAction $ Initiate (def, RPC1))
    , (0, ClientAction $ Send (NoMoreElems NoMetadata))
    , (0, ServerAction $ Send (NoMoreElems def))
    ]

-- | Server initiates response after client half-closes
allowHalfClosed3 :: Dialogue
allowHalfClosed3 = NormalizedDialogue [
      (0, ClientAction $ Initiate (def,RPC1))
    , (0, ClientAction $ Terminate (Just (SomeClientException 0)))
    , (0, ServerAction $ Initiate def)
    , (0, ServerAction $ Send (NoMoreElems def))
    ]