content: {-# LANGUAGE DataKinds        #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GADTs            #-}
  {-# LANGUAGE KindSignatures   #-}
  {-# LANGUAGE PolyKinds        #-}
  {-# LANGUAGE TypeOperators    #-}
  
  -- | Functions and types for creating a Serv response to match a 'Api.Api'.
  -- A value of @'Response' (s, 'Api.Respond' headers body)@ is a response
  -- with status code @s :: 'Status'@, response headers @headers ::
  -- [(Network.HTTP.Kinder.Header.HeaderName, *)]@ and a body described by
  -- @body :: 'Api.Body' *@.
  module Serv.Wai.Response (
  
    -- * Responses
      Response (..)
    , SomeResponse
  
    -- ** Construction
    , emptyResponse
    , withBody
    , withoutBody
    , withHeader
    , withHeaderQuiet
  
    -- ** Finalization
    -- | When constructing a response in our server implementation we do not
    -- build specific responses but instead responses which may be one of
    -- many possible server result types (parameterized by status codes). To
    -- represent this we use the 'SomeResponse' type and use 'respond' to
    -- convert from a normal 'Response' to 'SomeResponse'.
  
    , respond
  
  ) where
  
  import           Data.Singletons
  import           Network.HTTP.Kinder.Header (HeaderEncode, headerEncodePair)
  import           Network.HTTP.Kinder.Status (Status)
  import qualified Network.HTTP.Types         as HTTP
  import qualified Serv.Api                   as Api
  import           Serv.Wai.Corec
  import           Serv.Wai.Rec
  
  -- | A value of type @'Response (status, 'Api.Respond' headers body)@
  -- fully describes one response a Serv server might emit.
  data Response (x :: (Status, Api.Output *)) where
    ContentResponse
      :: [HTTP.Header] -> FieldRec hs -> a
      -> Response '(s, Api.Respond hs (Api.HasBody ts a))
    EmptyResponse
      :: [HTTP.Header] -> FieldRec hs
      -> Response '(s, Api.Respond hs Api.Empty)
  
  -- | A value of type @'SomeResponse rs'@ is a value of @'Response' (s, r)@
  -- such that @(s, r)@ is an element of @rs@.
  type SomeResponse rs = Corec Response rs
  
  -- | Forget the details of a specific response making it an approprate
  -- response at a given 'Api.Endpoint'
  respond :: ElemOf rs '(s, r) => Response '(s, r) -> SomeResponse rs
  respond = inject
  
  -- | The empty response at a given status code: no headers, no body.
  emptyResponse :: sing s -> Response '(s, Api.Respond '[] Api.Empty)
  emptyResponse _ = EmptyResponse [] RNil
  
  -- | Attach a body to an empty 'Response'.
  withBody
    :: a -> Response '(s, Api.Respond hs Api.Empty)
    -> Response '(s, Api.Respond hs (Api.HasBody ts a))
  withBody a (EmptyResponse secretHeaders headers) =
    ContentResponse secretHeaders headers a
  
  -- | Eliminate a body in a 'Response', returning it to 'Api.Empty'.
  withoutBody
    :: Response '(s, Api.Respond hs (Api.HasBody ts a))
    -> Response '(s, Api.Respond hs Api.Empty)
  withoutBody (ContentResponse secretHeaders headers _) =
    EmptyResponse secretHeaders headers
  
  -- | Adds a header to a 'Response'
  withHeader
    :: Sing name -> value
    -> Response '(s, Api.Respond headers body)
    -> Response '(s, Api.Respond ( '(name, value) ': headers) body)
  withHeader s val r = case r of
    ContentResponse secretHeaders headers body ->
      ContentResponse secretHeaders (s =: val <+> headers) body
    EmptyResponse secretHeaders headers ->
      EmptyResponse secretHeaders (s =: val <+> headers)
  
  -- | Unlike 'addHeader', 'addHeaderQuiet' allows you to add headers not
  -- explicitly specified in the api specification.
  withHeaderQuiet
    :: HeaderEncode name value
    => Sing name -> value
    -> Response '(s, Api.Respond headers body)
    -> Response '(s, Api.Respond headers body)
  withHeaderQuiet s value r =
    case headerEncodePair s value of
      Nothing -> r
      Just newHeader ->
        case r of
          ContentResponse secretHeaders headers body ->
            ContentResponse (newHeader : secretHeaders) headers body
          EmptyResponse secretHeaders headers ->
            EmptyResponse (newHeader : secretHeaders) headers
  