Serialization.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Prop.Serialization (tests) where

import Control.Lens ((.~))
import Control.Monad
import Control.Monad.Except (Except, runExcept)
import Control.Monad.State
import Data.Bifunctor
import Data.ByteString qualified as BS.Strict
import Data.ByteString qualified as Strict (ByteString)
import Data.ByteString.Base64 qualified as BS.Strict.Base64
import Data.ByteString.Char8 qualified as BS.Strict.Char8
import Data.CaseInsensitive qualified as CI
import Data.Char (isSpace)
import Data.Function
import Data.List (nubBy, uncons, intersperse)
import Data.Maybe (mapMaybe)
import Data.ProtoLens.Labels ()
import Data.ProtoLens.Message
import Data.Proxy
import Data.Text.Lazy qualified as Text.Lazy
import Data.TreeDiff (ToExpr, ediff, ansiWlEditExpr)
import Data.Void (Void)
import Network.HTTP.Types qualified as HTTP
import Prettyprinter (Doc)
import Prettyprinter qualified as PP
import Prettyprinter.Render.Terminal (AnsiStyle)
import Prettyprinter.Render.Terminal qualified as PP.Ansi
import Test.Tasty hiding (Timeout)
import Test.Tasty.QuickCheck

import Network.GRPC.Spec
import Network.GRPC.Spec.Serialization

import Test.Util.Awkward
import Test.Util.Orphans ()

tests :: TestTree
tests = testGroup "Test.Prop.Serialization" [
      testGroup "Base64" [
          testProperty "roundtrip" $
            roundtrip buildBinaryValue parseBinaryValue
        , testProperty "emitUnpadded" $ \(Awkward value) ->
            binaryNotPadded value
        , testProperty "acceptPadded" $
            roundtrip buildBinaryPadded parseBinaryValue
        , testProperty "acceptCommas" $ \cs ->
            roundtripWith
              (showIntermediate .*. labelHasMultipleChunks)
              (buildBinaryChunked cs)
              parseBinaryValue
        ]
    , testGroup "Headers" [
          testProperty "CustomMetadata" $
            roundtrip buildCustomMetadata parseCustomMetadata
        , testProperty "Timeout" $
            roundtrip buildTimeout parseTimeout
        , testProperty "Pushback" $
            roundtrip @Void buildPushback parsePushback
        , testProperty "RequestHeaders" $
            roundtrip (buildRequestHeaders rpc)
                      (parseRequestHeaders rpc)
        , testProperty "ResponseHeaders" $
            roundtrip (buildResponseHeaders rpc)
                      (parseResponseHeaders rpc)
        , testProperty "ProperTrailers" $
            roundtrip buildProperTrailers
                      (parseProperTrailers rpc)
        , testProperty "TrailersOnly" $
            roundtrip (buildTrailersOnly' rpc)
                      (parseTrailersOnly  rpc)
        ]
    , testGroup "Duplicates" [
          testProperty "RequestHeaders" $ \dups ->
            roundtripWith
              (showIntermediate .*. labelDups)
              (introduceDups dups . buildRequestHeaders rpc)
              (                     parseRequestHeaders rpc)
        , testProperty "ResponseHeaders" $ \dups ->
            roundtripWith
              (showIntermediate .*. labelDups)
              (introduceDups dups . buildResponseHeaders rpc)
              (                     parseResponseHeaders rpc)
        , testProperty "ProperTrailers" $ \dups ->
            roundtripWith
              (showIntermediate .*. labelDups)
              (introduceDups dups . buildProperTrailers)
              (                     parseProperTrailers rpc)
        , testProperty "TrailersOnly" $ \dups ->
            roundtripWith
              (showIntermediate .*. labelDups)
              (introduceDups dups . buildTrailersOnly' rpc)
              (                     parseTrailersOnly  rpc)
        ]
    , testGroup "Padding" [
          testProperty "RequestHeaders" $ \padding ->
            roundtripWith
              (showIntermediate .*. labelPadding)
              (introducePadding padding . buildRequestHeaders rpc)
              (                           parseRequestHeaders rpc)
        , testProperty "ResponseHeaders" $ \padding ->
            roundtripWith
              (showIntermediate .*. labelPadding)
              (introducePadding padding . buildResponseHeaders rpc)
              (                           parseResponseHeaders rpc)
        , testProperty "ProperTrailers" $ \padding ->
            roundtripWith
              (showIntermediate .*. labelPadding)
              (introducePadding padding . buildProperTrailers)
              (                           parseProperTrailers rpc)
        , testProperty "TrailersOnly" $ \padding ->
            roundtripWith
              (showIntermediate .*. labelPadding)
              (introducePadding padding . buildTrailersOnly' rpc)
              (                           parseTrailersOnly  rpc)
        ]
    ]
  where
    rpc = Proxy @(RawRpc "serv" "meth")

{-------------------------------------------------------------------------------
  Binary headers
-------------------------------------------------------------------------------}

-- | The gRPC spec mandates we should not /create/ padded values
binaryNotPadded :: Strict.ByteString -> Bool
binaryNotPadded = BS.Strict.Char8.all (/= '=') . buildBinaryValue

-- | The gRPC spec mandates we must /accept/ padded values
--
-- We cannot call 'buildBinaryValue' here, because it creates padded values
-- (as tested with 'binaryNotPadded').
buildBinaryPadded :: Strict.ByteString -> Strict.ByteString
buildBinaryPadded = BS.Strict.Base64.encode

-- | Build binary value by encoding chunks separately and joining the results
--
-- See 'parseBinaryValue' for detailed discussion.
--
-- We depend on the presence of commas here; see discussion in 'introduceDups',
-- with the corresponding statistics relevant to this case collected by
-- 'labelHasMultipleChunks'.
buildBinaryChunked :: [Bool] -> Strict.ByteString -> Strict.ByteString
buildBinaryChunked ds value =
    mconcat . intersperse "," $
      map buildBinaryValue chunks
  where
    chunks :: [Strict.ByteString]
    (chunks, _) =  splitHeaderValueBS ds value

labelHasMultipleChunks :: (a, Strict.ByteString) -> Property -> Property
labelHasMultipleChunks (_, bs) =
    tabulate "has multiple chunks" [
        show $ ',' `BS.Strict.Char8.elem` bs
      ]

{-------------------------------------------------------------------------------
  Duplicates in Custom-Metadata

  The spec mandates:

  > Custom-Metadata header order is not guaranteed to be preserved except for
  > values with duplicate header names. Duplicate header names may have their
  > values joined with "," as the delimiter and be considered semantically
  > equivalent.

  We need to be careful with whitespace around the delimeter here; the spec
  mandates

  > ASCII-Value should not have leading or trailing whitespace. If it contains
  > leading or trailing whitespace, it may be stripped.

  Since we use an internal representation that does not allow for duplicates, we
  test this by introducing duplicates in the /serialized/ form.
-------------------------------------------------------------------------------}

-- | Introduce duplicte headers
--
-- We introduce duplicates by splitting existing custom-metadata at existing
-- limiters (so that the roundtrip still passes), /if/ the corresponding 'Bool'
-- value is 'True' (so that we can shrink towards not introducing duplicates).
--
-- NOTE: Our generator for strict bytestrings generates commas with relatively
-- high probability, which ensures that we have enough source material here to
-- generate duplicate headers. We should keep an eye on the statistics however
-- to ensure that this continues to be the case (see 'labelDups').
introduceDups :: [Bool] -> [HTTP.Header] -> [HTTP.Header]
introduceDups = \dups -> concat . flip evalState dups . mapM go
  where
    go :: HTTP.Header -> State [Bool] [HTTP.Header]
    go hdr@(name, value)
      -- Don't split reserved headers (only metadata)
      | Nothing <- safeHeaderName (CI.foldedCase name)
      = return [hdr]

      -- We can split ASCII or binary headers
      | otherwise
      = state $ \dups -> first (map (name,)) $ splitHeaderValueBS dups value

splitHeaderValueBS ::
     [Bool]
  -> Strict.ByteString
  -> ([Strict.ByteString], [Bool])
splitHeaderValueBS ds =
      first (map BS.Strict.Char8.pack)
    . splitHeaderValue ds
    . BS.Strict.Char8.unpack

-- | Split a header value
--
-- We split the header value at @","@ boundaries, /provided/ that the comma is
-- not preceded or followed by whitespace (otherwise that whitespace would be
-- lost, since individual headers are trimmed).
--
-- Examples:
--
-- > splitHeaderValue []                "abc,def,ghi"  == (["abc,def,ghi"]     , [])
-- > splitHeaderValue [True]            "abc,def,ghi"  == (["abc","def,ghi"]   , [])
-- > splitHeaderValue [False]           "abc,def,ghi"  == (["abc,def,ghi"]     , [])
-- > splitHeaderValue [False,True]      "abc,def,ghi"  == (["abc,def","ghi"]   , [])
-- > splitHeaderValue [True,True]       "abc,def,ghi"  == (["abc","def","ghi"] , [])
-- > splitHeaderValue [True,False,True] "abc,def"      == (["abc","def"]       , [False,True])
-- > splitHeaderValue [True]            "abc, def,ghi" == (["abc, def","ghi"]  , [])
-- > splitHeaderValue [True]            "abc ,def,ghi" == (["abc ,def","ghi"]  , [])
splitHeaderValue ::
     [Bool]  -- ^ Allowed splits (useful to shrink towards splitting less)
  -> String  -- ^ String to split
  -> ([String], [Bool])
splitHeaderValue = go []
  where
    go ::
         [Char] -- Accumulated chunk, in reverse order
      -> [Bool] -- Allowed splits left
      -> String -- String left to process
      -> ([String], [Bool])
    go acc []     xs     = finalize acc [] xs
    go acc ds     []     = finalize acc ds []
    go acc (d:ds) (x:xs)
       | canSplit, d     = first (reverse acc :) $ go []         ds  xs
       | canSplit, not d =                         go (x:acc)    ds  xs
       | otherwise       =                         go (x:acc) (d:ds) xs
      where
        prevIsSpace, nextIsSpace, canSplit :: Bool
        prevIsSpace = maybe False (isSpace . fst) $ uncons acc
        nextIsSpace = maybe False (isSpace . fst) $ uncons xs
        canSplit    = x == ',' && not prevIsSpace && not nextIsSpace

    finalize :: [Char] -> [Bool] -> String -> ([String], [Bool])
    finalize acc ds xs = ([reverse acc ++ xs], ds)

labelDups :: (a, [HTTP.Header]) -> Property -> Property
labelDups (_a, headers) =
    tabulate "has duplicate headers" [
        show $ length headers /= length (nubBy ((==) `on` fst) headers)
      ]

{-------------------------------------------------------------------------------
  Roundtrip tests
-------------------------------------------------------------------------------}

roundtrip :: forall e a b.
     (Eq a, ToExpr a, Show b, Show e)
  => (a -> b)             -- ^ There
  -> (b -> Except e a)    -- ^ and back again
  -> Awkward a -> Property
roundtrip = roundtripWith showIntermediate

roundtripWith :: forall e a b.
     (Eq a, ToExpr a, Show e)
  => ((a, b) -> Property -> Property) -- ^ Statistics, metadata, ..
  -> (a -> b)             -- ^ There
  -> (b -> Except e a)    -- ^ and back again
  -> Awkward a -> Property
roundtripWith modProp there back (Awkward a) =
    modProp (a, b) $
      let ma' = runExcept (back b)
      in case ma' of
           Left err ->
                 counterexample (show err) False
           Right a'
             | a == a' ->
                 property True
             | otherwise ->
                 counterexample (renderDoc $ ansiWlEditExpr $ ediff a a') False
   where
     b :: b
     b = there a

showIntermediate :: Show b => (a, b) -> Property -> Property
showIntermediate (_, b) = counterexample (show b)

(.*.) ::
     ((a, b) -> Property -> Property)
  -> ((a, b) -> Property -> Property)
  -> ((a, b) -> Property -> Property)
(.*.) f g (a, b) = f (a, b) . g (a, b)

{-------------------------------------------------------------------------------
  Padding
-------------------------------------------------------------------------------}

newtype Padding = Padding {
      getPadding :: Strict.ByteString
    }
  deriving Show

instance Arbitrary Padding where
  arbitrary = do
      n <- choose (0, 5)
      Padding . BS.Strict.Char8.pack <$> replicateM n (elements " \t")
  shrink =
        map (Padding . BS.Strict.pack)
      . shrinkList (const []) -- only remove elements from the list
      . BS.Strict.unpack
      . getPadding

newtype PaddingPerHeader = PaddingPerHeader {
      -- | Left and right padding for each header
      getPaddingPerHeader :: [(Padding, Padding)]
    }
  deriving stock (Show)

instance Arbitrary PaddingPerHeader where
  arbitrary = sized $ \sz -> do
      n      <- choose (0, sz)
      PaddingPerHeader <$> replicateM n genPadding
    where
      -- Most of the time, no padding
      genPadding :: Gen (Padding, Padding)
      genPadding = frequency [
          (7, (,) <$> pure (Padding "") <*> pure (Padding ""))
        , (1, (,) <$> arbitrary         <*> pure (Padding ""))
        , (1, (,) <$> pure (Padding "") <*> arbitrary)
        , (1, (,) <$> arbitrary         <*> arbitrary)
        ]


  shrink =
        map PaddingPerHeader
      . shrinkList shrink
      . getPaddingPerHeader

introducePadding :: PaddingPerHeader -> [HTTP.Header] -> [HTTP.Header]
introducePadding = \(PaddingPerHeader padding) ->
    flip evalState padding . mapM go
  where
    go :: HTTP.Header -> State [(Padding, Padding)] HTTP.Header
    go (name, value) = state $ \case
      [] ->
        ((name, value), [])
      (l, r) : padding' ->
        ((name, getPadding l <> value <> getPadding r), padding')

labelPadding :: (a, [HTTP.Header]) -> Property -> Property
labelPadding (_a, headers) =
    tabulate "has padding" [
        show $ any (hasPadding . snd) headers
      ]
  where
    hasPadding :: Strict.ByteString -> Bool
    hasPadding bs = or [
          not . BS.Strict.null $ BS.Strict.Char8.takeWhile    isSpace bs
        , not . BS.Strict.null $ BS.Strict.Char8.takeWhileEnd isSpace bs
        ]

{-------------------------------------------------------------------------------
  Arbitrary instances

  We do not yet provide shrinkers for each definition; they should be defined if
  and when a test breaks.
-------------------------------------------------------------------------------}

instance Arbitrary (Awkward CustomMetadata) where
  arbitrary = Awkward <$> do
      name <- genName
      awkward `suchThatMap` safeCustomMetadata name
    where
      genName :: Gen HeaderName
      genName = oneof [
            getAwkward <$> arbitrary
          , fmap (<> "-bin") $ getAwkward <$> arbitrary
          ] `suchThatMap` safeHeaderName

  -- For now we shrink only the value
  shrink (Awkward (CustomMetadata name value)) =
      mapMaybe (fmap Awkward . safeCustomMetadata name) $ shrink value

instance Arbitrary (Awkward CustomMetadataMap) where
  arbitrary = Awkward <$>
      customMetadataMapFromList <$> awkward
  shrink =
        map (Awkward . customMetadataMapFromList . map getAwkward)
      . shrink
      . (map Awkward . customMetadataMapToList . getAwkward)

instance Arbitrary (Awkward RequestHeaders) where
  arbitrary = Awkward <$> do
      requestTimeout             <- awkward
      requestCompression         <- awkward
      requestAcceptCompression   <- awkward
      requestContentType         <- Just <$> awkward -- cannot be missing
      requestMessageType         <- Just <$> awkward -- cannot be missing
      requestUserAgent           <- awkward
      requestIncludeTE           <- arbitrary
      requestTraceContext        <- awkward
      requestPreviousRpcAttempts <- awkward
      requestMetadata            <- awkward
      return $ RequestHeaders{
          requestTimeout
        , requestCompression
        , requestAcceptCompression
        , requestContentType
        , requestMessageType
        , requestUserAgent
        , requestIncludeTE
        , requestTraceContext
        , requestPreviousRpcAttempts
        , requestMetadata
        , requestUnrecognized = ()
        }
  shrink h@(Awkward h') = concat [
        shrinkAwkward (\x -> h'{requestTimeout             = x}) requestTimeout             h
      , shrinkAwkward (\x -> h'{requestCompression         = x}) requestCompression         h
      , shrinkAwkward (\x -> h'{requestAcceptCompression   = x}) requestAcceptCompression   h
      , shrinkAwkward (\x -> h'{requestUserAgent           = x}) requestUserAgent           h
      , shrinkRegular (\x -> h'{requestIncludeTE           = x}) requestIncludeTE           h
      , shrinkAwkward (\x -> h'{requestTraceContext        = x}) requestTraceContext        h
      , shrinkAwkward (\x -> h'{requestPreviousRpcAttempts = x}) requestPreviousRpcAttempts h
      , shrinkAwkward (\x -> h'{requestMetadata            = x}) requestMetadata            h
      ]

instance Arbitrary (Awkward ResponseHeaders) where
  arbitrary = Awkward <$> do
      responseCompression       <- awkward
      responseAcceptCompression <- awkward
      responseContentType       <- Just <$> awkward
      responseMetadata          <- awkward
      return ResponseHeaders {
          responseCompression
        , responseAcceptCompression
        , responseContentType
        , responseMetadata
        , responseUnrecognized = ()
        }

  shrink h@(Awkward h') = concat [
        shrinkAwkward (\x -> h'{responseCompression       = x}) responseCompression       h
      , shrinkAwkward (\x -> h'{responseAcceptCompression = x}) responseAcceptCompression h
      , shrinkAwkward (\x -> h'{responseMetadata          = x}) responseMetadata          h
      ]

instance Arbitrary (Awkward ProperTrailers) where
  arbitrary = Awkward <$> do
      properTrailersGrpcStatus     <- awkward
      properTrailersGrpcMessage    <- awkward
      properTrailersStatusDetails  <- awkward
      properTrailersPushback       <- awkward
      properTrailersOrcaLoadReport <- awkward
      properTrailersMetadata       <- awkward
      return $ ProperTrailers{
          properTrailersGrpcStatus
        , properTrailersGrpcMessage
        , properTrailersStatusDetails
        , properTrailersPushback
        , properTrailersOrcaLoadReport
        , properTrailersMetadata
        , properTrailersUnrecognized = ()
        }

  shrink h@(Awkward h') = concat [
        shrinkAwkward (\x -> h'{properTrailersGrpcStatus     = x}) properTrailersGrpcStatus     h
      , shrinkAwkward (\x -> h'{properTrailersGrpcMessage    = x}) properTrailersGrpcMessage    h
      , shrinkAwkward (\x -> h'{properTrailersMetadata       = x}) properTrailersMetadata       h
      , shrinkAwkward (\x -> h'{properTrailersPushback       = x}) properTrailersPushback       h
      , shrinkAwkward (\x -> h'{properTrailersOrcaLoadReport = x}) properTrailersOrcaLoadReport h
      ]

instance Arbitrary (Awkward TrailersOnly) where
  arbitrary = Awkward <$> do
      trailersOnlyContentType <- Just <$> awkward
      trailersOnlyProper      <- awkward
      return $ TrailersOnly {
           trailersOnlyContentType
         , trailersOnlyProper
        }

  shrink h@(Awkward h') = concat [
        shrinkAwkward (\x -> h'{trailersOnlyContentType = x}) trailersOnlyContentType  h
      , shrinkAwkward (\x -> h'{trailersOnlyProper      = x}) trailersOnlyProper       h
      ]

instance Arbitrary (Awkward Timeout) where
  arbitrary = fmap Awkward $
      Timeout <$> awkward <*> awkward

instance Arbitrary (Awkward TimeoutUnit) where
  arbitrary = Awkward <$> elements [
        Hour
      , Minute
      , Second
      , Millisecond
      , Microsecond
      , Nanosecond
      ]

instance Arbitrary (Awkward TimeoutValue) where
  arbitrary = fmap Awkward $
      TimeoutValue <$> arbitrary `suchThat` isValidTimeoutValue
  shrink (Awkward (TimeoutValue x)) =
      map (Awkward . TimeoutValue) $ shrink x

instance Arbitrary (Awkward CompressionId) where
  arbitrary = Awkward <$> oneof [
        pure Identity
      , pure GZip
      , pure Deflate
      , pure Snappy
      , Custom <$> awkward `suchThatMap` validCompressionId
      ]
  shrink (Awkward cid) = Awkward <$>
      case cid of
        Identity -> []
        GZip     -> [Identity]
        Deflate  -> [Identity]
        Snappy   -> [Identity]
        Custom x -> concat [
            [Identity]
          , mapMaybe (fmap Custom . validCompressionId) $ shrink x
          ]

instance Arbitrary (Awkward ContentType) where
  arbitrary = Awkward <$>
      oneof [
          pure $ ContentTypeDefault
        , (\format -> ContentTypeOverride $ defaultRpcContentType format)
            <$> awkward `suchThatMap` validFormat
        ]
  shrink (Awkward ct) = Awkward <$>
      case ct of
        ContentTypeDefault     -> []
        ContentTypeOverride bs -> concat [
              [ContentTypeDefault]
            , [ ContentTypeOverride $ defaultRpcContentType format'
              | Just format <- [BS.Strict.Char8.stripPrefix ("application/grpc+") bs]
              , format' <- mapMaybe (validFormat . getAwkward) $ shrink (Awkward format)
              ]
            ]

instance Arbitrary (Awkward MessageType) where
  arbitrary = Awkward <$>
      oneof [
          pure $ MessageTypeDefault
        , MessageTypeOverride <$> awkward `suchThat` validMessageType
        ]

  shrink (Awkward mt) = Awkward <$>
      case mt of
        MessageTypeDefault    -> []
        MessageTypeOverride x -> concat [
            [MessageTypeDefault]
          , [ MessageTypeOverride x'
            | x' <- shrink x
            , validMessageType x'
            ]
          ]

instance Arbitrary (Awkward TraceContext) where
  arbitrary = Awkward <$> do
      traceContextTraceId <- awkward
      traceContextSpanId  <- awkward
      traceContextOptions <- awkward
      return TraceContext {
          traceContextTraceId
        , traceContextSpanId
        , traceContextOptions
        }

instance Arbitrary (Awkward TraceId) where
  arbitrary = Awkward <$> do
      tid <- replicateM 16 arbitrary -- length is fixed
      return $ TraceId $ BS.Strict.pack tid

instance Arbitrary (Awkward SpanId) where
  arbitrary = Awkward <$> do
      tid <- replicateM 8 arbitrary -- length is fixed
      return $ SpanId $ BS.Strict.pack tid

instance Arbitrary (Awkward TraceOptions) where
  arbitrary = Awkward <$> do
      traceOptionsSampled <- arbitrary
      return TraceOptions {
          traceOptionsSampled
        }

instance Arbitrary (Awkward GrpcStatus) where
  arbitrary = Awkward <$>
      elements [
          GrpcOk
        , GrpcError GrpcCancelled
        , GrpcError GrpcUnknown
        , GrpcError GrpcInvalidArgument
        , GrpcError GrpcDeadlineExceeded
        , GrpcError GrpcNotFound
        , GrpcError GrpcAlreadyExists
        , GrpcError GrpcPermissionDenied
        , GrpcError GrpcResourceExhausted
        , GrpcError GrpcFailedPrecondition
        , GrpcError GrpcAborted
        , GrpcError GrpcOutOfRange
        , GrpcError GrpcUnimplemented
        , GrpcError GrpcInternal
        , GrpcError GrpcUnavailable
        , GrpcError GrpcDataLoss
        , GrpcError GrpcUnauthenticated
        ]

instance Arbitrary (Awkward Pushback) where
  arbitrary = Awkward <$>
      oneof [
          RetryAfter <$> arbitrary
        , pure DoNotRetry
        ]

instance Arbitrary (Awkward OrcaLoadReport) where
  arbitrary = Awkward <$> do
      -- @rps@ is a deprecated field, we omit it from the test
      cpuUtilization         <- awkward
      memUtilization         <- awkward
      requestCost            <- awkward
      utilization            <- awkward
      rpsFractional          <- awkward
      eps                    <- awkward
      namedMetrics           <- awkward
      applicationUtilization <- awkward
      return $
        defMessage
          & #cpuUtilization         .~ cpuUtilization
          & #memUtilization         .~ memUtilization
          & #requestCost            .~ requestCost
          & #utilization            .~ utilization
          & #rpsFractional          .~ rpsFractional
          & #eps                    .~ eps
          & #namedMetrics           .~ namedMetrics
          & #applicationUtilization .~ applicationUtilization

{-------------------------------------------------------------------------------
  Generating valid values
-------------------------------------------------------------------------------}

validCompressionId :: String -> Maybe String
validCompressionId cid =
    case filter (not . forbiddenChar) cid of
      ""   -> Nothing
      cid' -> Just cid'
  where
    forbiddenChar :: Char -> Bool
    forbiddenChar c = or [
          isSpace c
        , c `elem` [',']
        ]

validFormat :: Strict.ByteString -> Maybe Strict.ByteString
validFormat format =
    case BS.Strict.Char8.filter (not . forbiddenChar) format of
      ""     -> Nothing
      "grpc" -> Nothing -- Would be parsed as @ContentTypeDefault@
      cid'   -> Just cid'
  where
    forbiddenChar :: Char -> Bool
    forbiddenChar c = or [
          isSpace c
        , c `elem` [';']
        ]

validMessageType :: Strict.ByteString -> Bool
validMessageType "Void" = False -- Would be parsed as @MessageTypeDefault@
validMessageType _      = True

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

renderDoc :: Doc AnsiStyle -> String
renderDoc =
      Text.Lazy.unpack
    . PP.Ansi.renderLazy
    . resetTerminal
    . PP.layoutPretty PP.defaultLayoutOptions
  where
    -- Reset the vivid red from tasty
    resetTerminal :: PP.SimpleDocStream AnsiStyle -> PP.SimpleDocStream AnsiStyle
    resetTerminal = PP.SAnnPush $ PP.Ansi.color PP.Ansi.Black

buildTrailersOnly' :: IsRPC rpc => Proxy rpc -> TrailersOnly -> [HTTP.Header]
buildTrailersOnly' rpc = buildTrailersOnly (Just . chooseContentType rpc)

type instance RequestMetadata          (RawRpc "serv" "meth") = NoMetadata
type instance ResponseInitialMetadata  (RawRpc "serv" "meth") = NoMetadata
type instance ResponseTrailingMetadata (RawRpc "serv" "meth") = NoMetadata