Invalid.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Dealing with invalid headers
module Network.GRPC.Spec.Headers.Invalid (
    InvalidHeaders(..)
  , InvalidHeader(..)
    -- * Construction
  , invalidHeader
  , missingHeader
  , unexpectedHeader
  , invalidHeaderSynthesize
  , throwInvalidHeader
    -- * Synthesized errors
  , HandledSynthesized
  , handledSynthesized
  , dropSynthesized
  , mapSynthesized
  , mapSynthesizedM
  , throwSynthesized
    -- * Utility
  , invalidHeaders
  , prettyInvalidHeaders
  , statusInvalidHeaders
  ) where

import Control.Monad.Except
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Builder qualified as ByteString (Builder)
import Data.ByteString.UTF8 qualified as BS.UTF8
import Data.CaseInsensitive qualified as CI
import Data.Foldable (asum)
import Data.Functor.Identity
import Data.Maybe (fromMaybe, mapMaybe)
import Network.HTTP.Types qualified as HTTP

import Network.GRPC.Spec.Status
import Network.GRPC.Spec.Util.HKD (Checked)
import Network.GRPC.Spec.Util.HKD qualified as HKD

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Invalid headers
--
-- This is used for request headers, response headers, and response trailers.
newtype InvalidHeaders e = InvalidHeaders {
      getInvalidHeaders :: [InvalidHeader e]
    }
  deriving stock (Show, Eq)
  deriving newtype (Semigroup, Monoid)

-- | Invalid header
--
-- This corresponds to a single \"raw\" HTTP header. It is possible that a
-- particular field of, say, 'Network.GRPC.Spec.Headers.Request.RequestHeaders'
-- corresponds to /multiple/ t'InvalidHeader', when the value of that field is
-- determined by combining multiple HTTP headers. A special case of this is the
-- field for unrecognized headers (see
-- 'Network.GRPC.Spec.Headers.Request.requestUnrecognized',
-- 'Network.GRPC.Spec.Headers.Response.responseUnrecognized', etc.), which
-- collects /all/ unrecognized headers in one field (and has value @()@ if there
-- are none).
--
-- For some invalid headers the gRPC spec mandates a specific HTTP status;
-- if this status is not specified, then we use 400 Bad Request.
data InvalidHeader e =
    -- | We failed to parse this header
    --
    -- We record the original header and the reason parsing failed.
    InvalidHeader (Maybe HTTP.Status) HTTP.Header String

    -- | Missing header (header that should have been present but was not)
  | MissingHeader (Maybe HTTP.Status) HTTP.HeaderName

    -- | Unexpected header (header that should not have been present but was)
  | UnexpectedHeader HTTP.HeaderName

    -- | Synthesize gRPC exception
    --
    -- This will be instantiated to 'Network.GRPC.Spec.GrpcException' after
    -- parsing, and to 'HandledSynthesized' once synthesized errors have been
    -- handled. See 'HandledSynthesized' for more details.
    --
    -- We record both the actual error and the synthesized error.
  | InvalidHeaderSynthesize e (InvalidHeader HandledSynthesized)
  deriving stock (Show, Eq)

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

-- | Convenience constructor around v'InvalidHeader'
invalidHeader :: Maybe HTTP.Status -> HTTP.Header -> String -> InvalidHeaders e
invalidHeader status hdr err = wrapOne $ InvalidHeader status hdr err

-- | Convenience constructor around v'MissingHeader'
missingHeader :: Maybe HTTP.Status -> HTTP.HeaderName -> InvalidHeaders e
missingHeader status name = wrapOne $ MissingHeader status name

-- | Convenience constructor around v'UnexpectedHeader'
unexpectedHeader :: HTTP.HeaderName -> InvalidHeaders e
unexpectedHeader name = wrapOne $ UnexpectedHeader name

-- | Convenience constructor around v'InvalidHeaderSynthesize'
invalidHeaderSynthesize ::
     e
  -> InvalidHeader HandledSynthesized
  -> InvalidHeaders e
invalidHeaderSynthesize e orig = wrapOne $ InvalidHeaderSynthesize e orig

-- | Convenience function for throwing an 'invalidHeader' exception.
throwInvalidHeader ::
     MonadError (InvalidHeaders e) m
  => HTTP.Header
  -> Either String a
  -> m a
throwInvalidHeader _   (Right a)  = return a
throwInvalidHeader hdr (Left err) = throwError $ invalidHeader Nothing hdr err

{-------------------------------------------------------------------------------
  Synthesized errors
-------------------------------------------------------------------------------}

-- | Indicate that all synthesized errors have been handled
--
-- For some headers the gRPC spec mandates a specific gRPC error that should
-- be synthesized when the header is invalid. We use 'HandledSynthesized'
-- in types to indicate that all errors that should have been synthesized have
-- already been thrown.
--
-- For example, 'Network.GRPC.Spec.RequestHeaders'' 'HandledSynthesized'
-- indicates that these request headers may still contain errors for some
-- headers, but no errors for which the spec mandates that we synthesize a
-- specific gRPC exception.
data HandledSynthesized

instance Show HandledSynthesized where
  show = handledSynthesized

instance Eq HandledSynthesized where
  x == _ = handledSynthesized x

-- | Evidence that 'HandledSynthesized' is an empty type
handledSynthesized :: HandledSynthesized -> a
handledSynthesized x = case x of {}

-- | Drop all synthesized errors, leaving just the original
dropSynthesized :: InvalidHeaders e -> InvalidHeaders HandledSynthesized
dropSynthesized = \(InvalidHeaders es) ->
    InvalidHeaders $ map aux es
  where
    aux :: InvalidHeader e -> InvalidHeader HandledSynthesized
    aux (InvalidHeader status (name, value) err) =
        InvalidHeader status (name, value) err
    aux (MissingHeader status name) =
        MissingHeader status name
    aux (UnexpectedHeader name) =
        UnexpectedHeader name
    aux (InvalidHeaderSynthesize _ orig) =
        orig

-- | Map over the errors
mapSynthesizedM :: forall m e e'.
     Monad m
  => (e -> m e')
  ->    InvalidHeaders e
  -> m (InvalidHeaders e')
mapSynthesizedM f = \(InvalidHeaders es) ->
    InvalidHeaders <$> go [] es
  where
    go :: [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
    go acc []     = pure $ reverse acc
    go acc (x:xs) =
        case x of
          InvalidHeader status (name, value) err ->
            go (InvalidHeader status (name, value) err : acc) xs
          MissingHeader status name ->
            go (MissingHeader status name : acc) xs
          UnexpectedHeader name ->
            go (UnexpectedHeader name : acc) xs
          InvalidHeaderSynthesize e orig -> do
            e' <- f e
            go (InvalidHeaderSynthesize e' orig : acc) xs

-- | Pure version of 'mapSynthesizedM'
mapSynthesized :: (e -> e') -> InvalidHeaders e -> InvalidHeaders e'
mapSynthesized f = runIdentity . mapSynthesizedM (Identity . f)

-- | Throw all synthesized errors
--
-- After this we are guaranteed that the synthesized errors have been handlded.
throwSynthesized ::
     (HKD.Traversable h, Monad m)
  => (forall a. GrpcException -> m a)
  ->    h (Checked (InvalidHeaders GrpcException))
  -> m (h (Checked (InvalidHeaders HandledSynthesized)))
throwSynthesized throw =
    HKD.traverse $
      either
        (fmap Left  . mapSynthesizedM throw)
        (fmap Right . return)

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

-- | Extract all invalid headers
invalidHeaders :: InvalidHeaders e -> [HTTP.Header]
invalidHeaders = \invalid ->
    case dropSynthesized invalid of
      InvalidHeaders es -> mapMaybe aux es
  where
    aux :: InvalidHeader HandledSynthesized -> Maybe HTTP.Header
    aux (InvalidHeader _status hdr _) = Just hdr
    aux MissingHeader{}               = Nothing
    aux UnexpectedHeader{}            = Nothing
    aux (InvalidHeaderSynthesize e _) = handledSynthesized e

-- | Render t'InvalidHeaders'
prettyInvalidHeaders :: InvalidHeaders HandledSynthesized -> ByteString.Builder
prettyInvalidHeaders = mconcat . map go . getInvalidHeaders
  where
    go :: InvalidHeader HandledSynthesized -> ByteString.Builder
    go (InvalidHeader _status (name, value) err) = mconcat [
          "Invalid header '"
        , Builder.byteString (CI.original name)
        , "' with value '"
        , Builder.byteString value
        , "': "
        , Builder.byteString $ BS.UTF8.fromString err
        , "\n"
        ]
    go (MissingHeader _status name) = mconcat [
          "Missing header '"
        , Builder.byteString (CI.original name)
        , "'\n"
        ]
    go (UnexpectedHeader name) = mconcat [
          "Unexpected header '"
        , Builder.byteString (CI.original name)
        , "'\n"
        ]
    go (InvalidHeaderSynthesize e _orig) =
        handledSynthesized e

-- | HTTP status to report
--
-- If there are multiple headers, each of which with a mandated status, we
-- just use the first; the spec is essentially ambiguous in this case.
statusInvalidHeaders :: InvalidHeaders HandledSynthesized -> HTTP.Status
statusInvalidHeaders (InvalidHeaders hs) =
    fromMaybe HTTP.badRequest400 $ asum $ map getStatus hs
  where
    getStatus :: InvalidHeader HandledSynthesized -> Maybe HTTP.Status
    getStatus (InvalidHeader status _ _)        = status
    getStatus (MissingHeader status _)          = status
    getStatus (UnexpectedHeader _)              = Nothing
    getStatus (InvalidHeaderSynthesize e _orig) = handledSynthesized e

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

wrapOne :: InvalidHeader e -> InvalidHeaders e
wrapOne = InvalidHeaders . (:[])