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

{-# LANGUAGE OverloadedStrings #-}

module Test.Driver.Dialogue.Definition (
    -- * Local
    LocalStep(..)
  , Action(..)
  , ClientAction
  , ServerAction
  , RPC(..)
  , TestMetadata(..)
    -- * Bird's-eye view
  , GlobalSteps(..)
  , LocalSteps(..)
    -- * Exceptions
    -- ** User exceptions
  , SomeClientException(..)
  , SomeServerException(..)
  , ExceptionId
    -- * Utility
  , hasEarlyTermination
  ) where

import Control.Monad.State (StateT, execStateT, modify)
import Data.Bifunctor
import Data.ByteString qualified as Strict (ByteString)

import Network.GRPC.Common

import Test.Driver.Dialogue.TestClock qualified as TestClock
import Test.Util.Exception
import Control.Monad.Catch
import GHC.Show (appPrec1, showCommaSpace)

{-------------------------------------------------------------------------------
  Single RPC
-------------------------------------------------------------------------------}

data LocalStep =
    ClientAction ClientAction
  | ServerAction ServerAction
  deriving stock (Show, Eq)

type ClientAction = Action (TestMetadata, RPC) NoMetadata   SomeClientException
type ServerAction = Action TestMetadata        TestMetadata SomeServerException

data Action a b e =
    -- | Initiate request and response
    --
    -- When the client initiates a request, they can specify a timeout, initial
    -- metadata for the request, as well as which endpoint to connect to. This
    -- must happen before anything else.
    --
    -- On the server side an explicit 'Initiate' is not required; if not
    -- present, there will be an implicit one, with empty metadata, on the first
    -- 'Send'.
    Initiate a

    -- | Send a message to the peer
  | Send (StreamElem b Int)

    -- | Early termination (cleanly or with an exception)
  | Terminate (Maybe e)
  deriving stock (Show, Eq)

data RPC = RPC1 | RPC2 | RPC3
  deriving stock (Show, Eq)

{-------------------------------------------------------------------------------
  Metadata
-------------------------------------------------------------------------------}

data TestMetadata = TestMetadata {
      metadataAsc1 :: Maybe Strict.ByteString
    , metadataAsc2 :: Maybe Strict.ByteString
    , metadataBin3 :: Maybe Strict.ByteString
    , metadataBin4 :: Maybe Strict.ByteString
    }
  deriving (Eq)

-- | Hand-written 'Show' instance which shows @def :: TestMetadata@ as @def@
--
-- This is by far the most common value that shows up in test failures, so this
-- improves readability.
instance Show TestMetadata where
  showsPrec _ (TestMetadata Nothing Nothing Nothing Nothing) = showString "def"
  showsPrec p (TestMetadata asc1 asc2 bin3 bin4) = showParen (p >= appPrec1) $
        showString "TestMetadata {"
      . showString "metadataAsc1 = "
      . showVal asc1
      . showCommaSpace
      . showString "metadataAsc2 = "
      . showVal asc2
      . showCommaSpace
      . showString "metadataBin3 = "
      . showVal bin3
      . showCommaSpace
      . showString "metadataBin4 = "
      . showVal bin4
      . showString "}"
    where
      showVal Nothing  = showString "def"
      showVal (Just x) = showsPrec 0 (Just x)

instance Default TestMetadata where
  def = TestMetadata {
        metadataAsc1 = Nothing
      , metadataAsc2 = Nothing
      , metadataBin3 = Nothing
      , metadataBin4 = Nothing
      }

instance BuildMetadata TestMetadata where
  buildMetadata md = concat [
        [ CustomMetadata "md1"     x | Just x <- [metadataAsc1 md]]
      , [ CustomMetadata "md2"     x | Just x <- [metadataAsc2 md]]
      , [ CustomMetadata "md3-bin" x | Just x <- [metadataBin3 md]]
      , [ CustomMetadata "md4-bin" x | Just x <- [metadataBin4 md]]
      ]

instance ParseMetadata TestMetadata where
  parseMetadata = flip execStateT def . mapM go
    where
      go :: MonadThrow m => CustomMetadata -> StateT TestMetadata m ()
      go md
        | customMetadataName md == "md1"
        = modify $ \x -> x{metadataAsc1 = Just $ customMetadataValue md}

        | customMetadataName md == "md2"
        = modify $ \x -> x{metadataAsc2 = Just $ customMetadataValue md}

        | customMetadataName md == "md3-bin"
        = modify $ \x -> x{metadataBin3 = Just $ customMetadataValue md}

        | customMetadataName md == "md4-bin"
        = modify $ \x -> x{metadataBin4 = Just $ customMetadataValue md}

        | otherwise
        = throwM $ UnexpectedMetadata [md]

instance StaticMetadata TestMetadata where
  metadataHeaderNames _ = ["md1", "md2", "md3-bin", "md4-bin"]

{-------------------------------------------------------------------------------
  Many RPCs (bird's-eye view)
-------------------------------------------------------------------------------}

newtype LocalSteps = LocalSteps {
      getLocalSteps :: [(TestClock.Tick, LocalStep)]
    }
  deriving stock (Show)

newtype GlobalSteps = GlobalSteps {
      getGlobalSteps :: [LocalSteps]
    }
  deriving stock (Show)

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

-- | Check if the client or server terminate early
hasEarlyTermination :: GlobalSteps -> (Bool, Bool)
hasEarlyTermination =
      bimap or or
    . unzip
    . map (isEarlyTermination . snd)
    . concatMap getLocalSteps
    . getGlobalSteps
  where
    isEarlyTermination :: LocalStep -> (Bool, Bool)
    isEarlyTermination (ClientAction (Terminate _)) = (True, False)
    isEarlyTermination (ServerAction (Terminate _)) = (False, True)
    isEarlyTermination _                            = (False, False)