{-# LANGUAGE OverloadedStrings #-}

-- | Custom metadata
--
-- These are application-defined headers/trailers.
--
-- Intended for unqualified import.
module Network.GRPC.Spec.CustomMetadata.Raw (
    -- * Definition
    CustomMetadata(CustomMetadata)
  , customMetadataName
  , customMetadataValue
  , safeCustomMetadata
  , HeaderName(BinaryHeader, AsciiHeader)
  , safeHeaderName
  , isValidAsciiValue
  ) where

import Control.DeepSeq (NFData)
import Control.Monad
import Data.ByteString qualified as BS.Strict
import Data.ByteString qualified as Strict (ByteString)
import Data.List qualified as List
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.String
import Data.Word
import GHC.Generics (Generic)
import GHC.Show
import GHC.Stack

import Network.GRPC.Spec.Util.ByteString (strip, ascii)

{-------------------------------------------------------------------------------
  Definition

  > Custom-Metadata → Binary-Header / ASCII-Header
  > Binary-Header   → {Header-Name "-bin" } {base64 encoded value}
  > ASCII-Header    → Header-Name ASCII-Value

  Implementation note: ASCII headers and binary headers are distinguished based
  on their name (see 'HeaderName'). We do /not/ introduce a different type for
  the /values/ of such headers, because if we did, we would then need additional
  machinery to make sure that binary header names are paired with binary header
  values, and similarly for ASCII headers, with little benefit. Instead we check
  in the smart constructor for 'CustomMetadata' that the header value satisfies
  the rules for the particular type of header.
-------------------------------------------------------------------------------}

-- | Custom metadata
--
-- This is an arbitrary set of key-value pairs defined by the application layer.
--
-- Custom metadata 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.
data CustomMetadata = UnsafeCustomMetadata {
      -- | Header name
      --
      -- The header name determines if this is an ASCII header or a binary
      -- header; see the t'CustomMetadata' pattern synonym.
      CustomMetadata -> HeaderName
customMetadataName :: HeaderName

      -- | Header value
    , CustomMetadata -> ByteString
customMetadataValue :: Strict.ByteString
    }
  deriving stock (CustomMetadata -> CustomMetadata -> Bool
(CustomMetadata -> CustomMetadata -> Bool)
-> (CustomMetadata -> CustomMetadata -> Bool) -> Eq CustomMetadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CustomMetadata -> CustomMetadata -> Bool
== :: CustomMetadata -> CustomMetadata -> Bool
$c/= :: CustomMetadata -> CustomMetadata -> Bool
/= :: CustomMetadata -> CustomMetadata -> Bool
Eq, (forall x. CustomMetadata -> Rep CustomMetadata x)
-> (forall x. Rep CustomMetadata x -> CustomMetadata)
-> Generic CustomMetadata
forall x. Rep CustomMetadata x -> CustomMetadata
forall x. CustomMetadata -> Rep CustomMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CustomMetadata -> Rep CustomMetadata x
from :: forall x. CustomMetadata -> Rep CustomMetadata x
$cto :: forall x. Rep CustomMetadata x -> CustomMetadata
to :: forall x. Rep CustomMetadata x -> CustomMetadata
Generic)
  deriving anyclass (CustomMetadata -> ()
(CustomMetadata -> ()) -> NFData CustomMetadata
forall a. (a -> ()) -> NFData a
$crnf :: CustomMetadata -> ()
rnf :: CustomMetadata -> ()
NFData)

-- | 'Show' instance relies on the v'CustomMetadata' pattern synonym
instance Show CustomMetadata where
  showsPrec :: Int -> CustomMetadata -> ShowS
showsPrec Int
p (UnsafeCustomMetadata HeaderName
name ByteString
value) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
         [Char] -> ShowS
showString [Char]
"CustomMetadata "
       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HeaderName -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
appPrec1 HeaderName
name
       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showSpace
       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
appPrec1 ByteString
value

-- | Check for valid ASCII header value
--
-- > ASCII-Value → 1*( %x20-%x7E ) ; space and printable ASCII
--
-- NOTE: By rights this should verify that the header is non-empty. However,
-- empty header values do occasionally show up, and so we permit them. The main
-- reason for checking for validity at all is to ensure that we don't confuse
-- binary headers and ASCII headers.
isValidAsciiValue :: Strict.ByteString -> Bool
isValidAsciiValue :: ByteString -> Bool
isValidAsciiValue ByteString
bs = (Word8 -> Bool) -> ByteString -> Bool
BS.Strict.all (\Word8
c -> Word8
0x20 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7E) ByteString
bs

-- | Construct t'CustomMetadata'
--
-- Returns 'Nothing' if the 'HeaderName' indicates an ASCII header but the
-- value is not valid ASCII (consider using a binary header instead).
safeCustomMetadata :: HeaderName -> Strict.ByteString -> Maybe CustomMetadata
safeCustomMetadata :: HeaderName -> ByteString -> Maybe CustomMetadata
safeCustomMetadata HeaderName
name ByteString
value =
    case HeaderName
name of
      UnsafeAsciiHeader ByteString
_ -> do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
isValidAsciiValue ByteString
value
        CustomMetadata -> Maybe CustomMetadata
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CustomMetadata -> Maybe CustomMetadata)
-> CustomMetadata -> Maybe CustomMetadata
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> CustomMetadata
UnsafeCustomMetadata HeaderName
name (ByteString -> ByteString
strip ByteString
value)
      UnsafeBinaryHeader ByteString
_ ->
        -- Values of binary headers are not subject to any constraints
        CustomMetadata -> Maybe CustomMetadata
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CustomMetadata -> Maybe CustomMetadata)
-> CustomMetadata -> Maybe CustomMetadata
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> CustomMetadata
UnsafeCustomMetadata HeaderName
name ByteString
value

pattern CustomMetadata ::
     HasCallStack
  => HeaderName -> Strict.ByteString -> CustomMetadata
pattern $bCustomMetadata :: HasCallStack => HeaderName -> ByteString -> CustomMetadata
$mCustomMetadata :: forall {r}.
HasCallStack =>
CustomMetadata
-> (HeaderName -> ByteString -> r) -> ((# #) -> r) -> r
CustomMetadata name value <- UnsafeCustomMetadata name value
  where
    CustomMetadata HeaderName
name ByteString
value =
        CustomMetadata -> Maybe CustomMetadata -> CustomMetadata
forall a. a -> Maybe a -> a
fromMaybe (CustomMetadata -> CustomMetadata
forall a b. (Show a, HasCallStack) => a -> b
invalid CustomMetadata
constructedForError) (Maybe CustomMetadata -> CustomMetadata)
-> Maybe CustomMetadata -> CustomMetadata
forall a b. (a -> b) -> a -> b
$
          HeaderName -> ByteString -> Maybe CustomMetadata
safeCustomMetadata HeaderName
name ByteString
value
      where
        constructedForError :: CustomMetadata
        constructedForError :: CustomMetadata
constructedForError = HeaderName -> ByteString -> CustomMetadata
UnsafeCustomMetadata HeaderName
name ByteString
value

{-# COMPLETE CustomMetadata #-}

{-------------------------------------------------------------------------------
  Header-Name

  > Header-Name → 1*( %x30-39 / %x61-7A / "_" / "-" / ".") ; 0-9 a-z _ - .
----------------------\--------------------------------------------------------}

-- | Header name
--
-- To construct a 'HeaderName', you can either use the 'IsString' instance
--
-- > "foo"     :: HeaderName -- an ASCII header
-- > "bar-bin" :: HeaderName -- a binary header
--
-- or alternatively use the 'AsciiHeader' and 'BinaryHeader' patterns
--
-- > AsciiHeader  "foo"
-- > BinaryHeader "bar-bin"
--
-- The latter style is more explicit, and can catch more errors:
--
-- > AsciiHeader  "foo-bin" -- exception: unexpected -bin suffix
-- > BinaryHeader "bar"     -- exception: expected   -bin suffix
--
-- Header names cannot be empty, and must consist of digits (@0-9@), lowercase
-- letters (@a-z@), underscore (@_@), hyphen (@-@), or period (@.@).
-- Reserved header names are disallowed.
--
-- See also 'safeHeaderName'.
data HeaderName =
    -- | Binary header
    --
    -- Binary headers will be base-64 encoded.
    --
    -- The header name must have a @-bin@ suffix (runtime libraries use this
    -- suffix to detect binary headers and properly apply base64 encoding &
    -- decoding as headers are sent and received).
    --
    -- Since this is binary data, padding considerations do not apply.
    UnsafeBinaryHeader Strict.ByteString

    -- | ASCII header
    --
    -- ASCII headers cannot be empty, and can only use characters in the range
    -- @0x20 .. 0x7E@. Note that although this range includes whitespace, any
    -- padding will be removed when constructing the value.
    --
    -- The gRPC spec is not precise about what exactly constitutes \"padding\",
    -- but the ABNF spec defines it as "space and horizontal tab"
    -- <https://www.rfc-editor.org/rfc/rfc5234#section-3.1>.
  | UnsafeAsciiHeader Strict.ByteString
  deriving stock (HeaderName -> HeaderName -> Bool
(HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> Bool) -> Eq HeaderName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderName -> HeaderName -> Bool
== :: HeaderName -> HeaderName -> Bool
$c/= :: HeaderName -> HeaderName -> Bool
/= :: HeaderName -> HeaderName -> Bool
Eq, Eq HeaderName
Eq HeaderName =>
(HeaderName -> HeaderName -> Ordering)
-> (HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> Bool)
-> (HeaderName -> HeaderName -> HeaderName)
-> (HeaderName -> HeaderName -> HeaderName)
-> Ord HeaderName
HeaderName -> HeaderName -> Bool
HeaderName -> HeaderName -> Ordering
HeaderName -> HeaderName -> HeaderName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HeaderName -> HeaderName -> Ordering
compare :: HeaderName -> HeaderName -> Ordering
$c< :: HeaderName -> HeaderName -> Bool
< :: HeaderName -> HeaderName -> Bool
$c<= :: HeaderName -> HeaderName -> Bool
<= :: HeaderName -> HeaderName -> Bool
$c> :: HeaderName -> HeaderName -> Bool
> :: HeaderName -> HeaderName -> Bool
$c>= :: HeaderName -> HeaderName -> Bool
>= :: HeaderName -> HeaderName -> Bool
$cmax :: HeaderName -> HeaderName -> HeaderName
max :: HeaderName -> HeaderName -> HeaderName
$cmin :: HeaderName -> HeaderName -> HeaderName
min :: HeaderName -> HeaderName -> HeaderName
Ord, (forall x. HeaderName -> Rep HeaderName x)
-> (forall x. Rep HeaderName x -> HeaderName) -> Generic HeaderName
forall x. Rep HeaderName x -> HeaderName
forall x. HeaderName -> Rep HeaderName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HeaderName -> Rep HeaderName x
from :: forall x. HeaderName -> Rep HeaderName x
$cto :: forall x. Rep HeaderName x -> HeaderName
to :: forall x. Rep HeaderName x -> HeaderName
Generic)
  deriving anyclass (HeaderName -> ()
(HeaderName -> ()) -> NFData HeaderName
forall a. (a -> ()) -> NFData a
$crnf :: HeaderName -> ()
rnf :: HeaderName -> ()
NFData)

pattern BinaryHeader :: HasCallStack => Strict.ByteString -> HeaderName
pattern $bBinaryHeader :: HasCallStack => ByteString -> HeaderName
$mBinaryHeader :: forall {r}.
HasCallStack =>
HeaderName -> (ByteString -> r) -> ((# #) -> r) -> r
BinaryHeader name <- UnsafeBinaryHeader name
  where
    BinaryHeader ByteString
name =
      case ByteString -> Maybe HeaderName
safeHeaderName ByteString
name of
        Just name' :: HeaderName
name'@UnsafeBinaryHeader{} ->
          HeaderName
name'
        Just UnsafeAsciiHeader{} ->
          [Char] -> HeaderName
forall a. HasCallStack => [Char] -> a
error [Char]
"binary headers must have -bin suffix"
        Maybe HeaderName
Nothing ->
          [Char] -> HeaderName
forall a. HasCallStack => [Char] -> a
error ([Char] -> HeaderName) -> [Char] -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid header name " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
name

pattern AsciiHeader :: HasCallStack => Strict.ByteString -> HeaderName
pattern $bAsciiHeader :: HasCallStack => ByteString -> HeaderName
$mAsciiHeader :: forall {r}.
HasCallStack =>
HeaderName -> (ByteString -> r) -> ((# #) -> r) -> r
AsciiHeader name <- UnsafeAsciiHeader name
  where
    AsciiHeader ByteString
name =
      case ByteString -> Maybe HeaderName
safeHeaderName ByteString
name of
        Just name' :: HeaderName
name'@UnsafeAsciiHeader{} ->
          HeaderName
name'
        Just UnsafeBinaryHeader{} ->
          [Char] -> HeaderName
forall a. HasCallStack => [Char] -> a
error [Char]
"ASCII headers cannot have -bin suffix"
        Maybe HeaderName
Nothing ->
          [Char] -> HeaderName
forall a. HasCallStack => [Char] -> a
error ([Char] -> HeaderName) -> [Char] -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid header name " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
name

{-# COMPLETE BinaryHeader, AsciiHeader #-}

-- | Check for header name validity
--
-- We choose between 'BinaryHeader' and 'AsciiHeader' based on the presence or
-- absence of a @-bin suffix.
safeHeaderName :: Strict.ByteString -> Maybe HeaderName
safeHeaderName :: ByteString -> Maybe HeaderName
safeHeaderName ByteString
bs = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.Strict.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> Bool
BS.Strict.all Word8 -> Bool
isValidChar ByteString
bs
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
"grpc-" ByteString -> ByteString -> Bool
`BS.Strict.isPrefixOf` ByteString
bs
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ByteString
reservedNames
    HeaderName -> Maybe HeaderName
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderName -> Maybe HeaderName) -> HeaderName -> Maybe HeaderName
forall a b. (a -> b) -> a -> b
$ if ByteString
"-bin" ByteString -> ByteString -> Bool
`BS.Strict.isSuffixOf` ByteString
bs
               then ByteString -> HeaderName
UnsafeBinaryHeader ByteString
bs
               else ByteString -> HeaderName
UnsafeAsciiHeader  ByteString
bs
  where
    isValidChar :: Word8 -> Bool
    isValidChar :: Word8 -> Bool
isValidChar Word8
c = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [
          Word8
0x30 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x39
        , Word8
0x61 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7A
        , Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'_'
        , Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'-'
        , Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'.'
        ]

    -- Reserved header names that do not start with @grpc-@
    reservedNames :: Set Strict.ByteString
    reservedNames :: Set ByteString
reservedNames = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [
          ByteString
"user-agent"
        , ByteString
"content-type"
        , ByteString
"te"
        , ByteString
"trailer"
        ]

instance IsString HeaderName where
  fromString :: [Char] -> HeaderName
fromString [Char]
str =
       HeaderName -> Maybe HeaderName -> HeaderName
forall a. a -> Maybe a -> a
fromMaybe (HeaderName -> HeaderName
forall a b. (Show a, HasCallStack) => a -> b
invalid HeaderName
constructedForError) (Maybe HeaderName -> HeaderName) -> Maybe HeaderName -> HeaderName
forall a b. (a -> b) -> a -> b
$
         ByteString -> Maybe HeaderName
safeHeaderName ([Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
str)
    where
      constructedForError :: HeaderName
      constructedForError :: HeaderName
constructedForError =
          if [Char]
"-bin" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isSuffixOf` [Char]
str
            then ByteString -> HeaderName
UnsafeBinaryHeader (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
str
            else ByteString -> HeaderName
UnsafeAsciiHeader  (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
str

-- | 'Show' instance relies on the 'IsString' instance
instance Show HeaderName where
  show :: HeaderName -> [Char]
show (UnsafeBinaryHeader ByteString
name) = ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
name
  show (UnsafeAsciiHeader  ByteString
name) = ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
name

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

invalid :: (Show a, HasCallStack) => a -> b
invalid :: forall a b. (Show a, HasCallStack) => a -> b
invalid a
x = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" at "