Session.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.GRPC.Client.Session (
    ClientSession(..)
  , ClientInbound
  , ClientOutbound
  , Headers(..)
    -- * Exceptions
  , CallSetupFailure(..)
  , InvalidTrailers(..)
  ) where

import Control.Exception
import Data.Proxy
import Data.Void
import Network.HTTP.Types qualified as HTTP

import Network.GRPC.Client.Connection (Connection, ConnParams(..))
import Network.GRPC.Client.Connection qualified as Connection
import Network.GRPC.Common
import Network.GRPC.Common.Compression qualified as Compr
import Network.GRPC.Common.Headers
import Network.GRPC.Spec
import Network.GRPC.Spec.Serialization
import Network.GRPC.Util.Session

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

data ClientSession rpc = ClientSession {
      clientConnection :: Connection
    }

{-------------------------------------------------------------------------------
  Instances
-------------------------------------------------------------------------------}

data ClientInbound rpc
data ClientOutbound rpc

instance IsRPC rpc => DataFlow (ClientInbound rpc) where
  data Headers (ClientInbound rpc) = InboundHeaders {
        inbHeaders     :: ResponseHeaders' HandledSynthesized
      , inbCompression :: Compression
      }
    deriving (Show)

  type Message    (ClientInbound rpc) = (InboundMeta, Output rpc)
  type Trailers   (ClientInbound rpc) = ProperTrailers'
  type NoMessages (ClientInbound rpc) = TrailersOnly' HandledSynthesized

instance IsRPC rpc => DataFlow (ClientOutbound rpc) where
  data Headers (ClientOutbound rpc) = OutboundHeaders {
        outHeaders     :: RequestHeaders
      , outCompression :: Compression
      }
    deriving (Show)

  type Message  (ClientOutbound rpc) = (OutboundMeta, Input rpc)
  type Trailers (ClientOutbound rpc) = NoMetadata

  -- gRPC does not support a Trailers-Only case for requests
  -- (indeed, does not support request trailers at all).
  type NoMessages (ClientOutbound rpc) = Void

instance SupportsClientRpc rpc => IsSession (ClientSession rpc) where
  type Inbound  (ClientSession rpc) = ClientInbound  rpc
  type Outbound (ClientSession rpc) = ClientOutbound rpc

  buildOutboundTrailers _ = \NoMetadata -> []
  parseInboundTrailers  _ = \trailers ->
      if null trailers then
        -- Although we parse the trailers in a lenient fashion (like all
        -- headers), only throwing errors for headers that we really need, if we
        -- get no trailers at /all/, then most likely something has gone wrong;
        -- for example, perhaps an intermediate cache has dropped the gRPC
        -- trailers entirely. We therefore check for this case separately and
        -- throw a different error.
        --
        -- We /must/ throw a GrpcException (rather than some kind of custom one)
        -- because the spec mandates that we synthesize a status and status
        -- message when the peer omits them.
        throwIO $ GrpcException {
            grpcError         = GrpcUnknown
          , grpcErrorMessage  = Just "Call closed without trailers"
          , grpcErrorDetails  = Nothing
          , grpcErrorMetadata = []
          }
      else
        return $ parseProperTrailers' (Proxy @rpc) trailers

  parseMsg _ = parseOutput (Proxy @rpc) . inbCompression
  buildMsg _ = buildInput  (Proxy @rpc) . outCompression

instance SupportsClientRpc rpc => InitiateSession (ClientSession rpc) where
  parseResponse (ClientSession conn) (ResponseInfo status headers body) =
      case classifyServerResponse (Proxy @rpc) status headers body of
        Left parsed -> do
          trailersOnly <- throwSynthesized throwIO parsed
          -- We classify the response as Trailers-Only if the grpc-status header
          -- is present, or when the HTTP status is anything other than 200 OK
          -- (which we treat, as per the spec, as an implicit grpc-status).
          -- The "closed without trailers" case is therefore not relevant.
          case verifyAllIf connVerifyHeaders trailersOnly of
            Left  err   -> throwIO $ CallSetupInvalidResponseHeaders err
            Right _hdrs -> return $ FlowStartNoMessages trailersOnly
        Right parsed -> do
          responseHeaders <- throwSynthesized throwIO parsed
          case verifyAllIf connVerifyHeaders responseHeaders of
            Left  err  -> throwIO $ CallSetupInvalidResponseHeaders err
            Right hdrs -> do
              Connection.updateConnectionMeta conn responseHeaders
              cIn <- getCompression $ requiredResponseCompression hdrs
              return $ FlowStartRegular $ InboundHeaders {
                  inbHeaders     = responseHeaders
                , inbCompression = cIn
                }
    where
      ConnParams{
          connCompression
        , connVerifyHeaders
        } = Connection.connParams conn

      getCompression :: Maybe CompressionId -> IO Compression
      getCompression Nothing    = return noCompression
      getCompression (Just cid) =
          case Compr.getSupported connCompression cid of
            Just compr -> return compr
            Nothing    -> throwIO $ CallSetupUnsupportedCompression cid

  buildRequestInfo _ start = RequestInfo {
        requestMethod  = rawMethod resourceHeaders
      , requestPath    = rawPath resourceHeaders
      , requestHeaders = buildRequestHeaders (Proxy @rpc) $
            case start of
              FlowStartRegular    headers    -> outHeaders headers
              FlowStartNoMessages impossible -> absurd impossible
      }
    where
      resourceHeaders :: RawResourceHeaders
      resourceHeaders = buildResourceHeaders $ ResourceHeaders {
            resourceMethod = Post
          , resourcePath   = rpcPath (Proxy @rpc)
          }

instance NoTrailers (ClientSession rpc) where
  noTrailers _ = NoMetadata

{-------------------------------------------------------------------------------
  Exceptions
-------------------------------------------------------------------------------}

data CallSetupFailure =
    -- | Server chose an unsupported compression algorithm
    CallSetupUnsupportedCompression CompressionId

    -- | We failed to parse the response headers
  | CallSetupInvalidResponseHeaders (InvalidHeaders HandledSynthesized)
  deriving stock (Show)
  deriving anyclass (Exception)

-- | We failed to parse the response trailers
data InvalidTrailers =
    -- | Some of the trailers could not be parsed
    InvalidTrailers {
        invalidTrailers      :: [HTTP.Header]
      , invalidTrailersError :: String
      }
  deriving stock (Show)
  deriving anyclass (Exception)