{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}


-- |
--
-- Module      : Servant.ActiveResource
-- Copyright   : (C) 2024 Bellroy Pty Ltd
-- License     : BSD-3-Clause
-- Maintainer  : Bellroy Tech Team <haskell@bellroy.com>
-- Stability   : experimental
--
-- Types and helpers for defining Servant routes compatible with
-- [Rails' ActiveResource](https://github.com/rails/activeresource).
--
-- @
-- {-# LANGUAGE TemplateHaskell #-}
--
-- import qualified Servant.ActiveResource as AR
--
-- newtype MyResourceId = MyResourceId Int
-- -- Type for new values or updates to existing values. Usually
-- -- missing an @id@ field.
-- data MyResource = MyResource {...}
-- -- Like MyResource, but returned from the database.
-- data MyStoredResource = MyStoredResource {...}
--
-- -- The exact monad used will depend on your program. Here, we just assume
-- -- 'Handler' from package servant-server.
-- instance AR.'Resource' MyResourceId Handler where
--   type 'ResourceData' MyResourceId = MyResource
--   type 'StoredResourceData' MyResourceId = MyStoredResource
--
--   -- These form the implementation of your API.
--   'listResources' = ...
--   'createResource' = ...
--   'readResource' = ...
--   'upsertResource' = ...
--   'deleteResource' = ...
--
-- -- Record of routes, which can be spliced into a top-level handler
-- -- via 'Servant.API.NamedRoutes'.
-- routes :: AR.'ResourceRoutes' MyResourceId (AsServerT Handler)
-- routes = $(AR.'makeResourceServerT' [t|MyResourceId|])
-- @
module Servant.ActiveResource
  ( Resource (..),
    NotFoundError (..),
    ValidationError (..),
    CreatedUpdated (..),
    ResourceRoutes (..),
    makeResourceServerT,
    errorFormatters,
  )
where

import Control.Monad ((>=>))
import Data.Aeson (ToJSON (..), Value (..), object, (.=))
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Kind (Type)
import Data.Map (Map)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import GHC.Generics (Generic)
import qualified Language.Haskell.TH as TH
import Servant.API
  ( Capture,
    JSON,
    NoContent (..), -- ctor import needed by TH
    ReqBody,
    StdMethod (..),
    UVerb,
    WithStatus (..), -- ctor import needed by TH
    (:>),
  )
import Servant.API.ContentTypes (handleAcceptH)
import Servant.API.Generic ((:-))
import Servant.Server
  ( ErrorFormatters (..),
    defaultErrorFormatters,
    err422,
    errBody,
    errHeaders,
    getAcceptHeader,
    respond, -- needed by TH
  )

-- | A 'Resource' instance says that the type @id@ is the primary
-- key for some abstract resource, and that the collection of such
-- resources can be manipulated with CRUDL actions inside a Monad @m@.
class (Monad m) => Resource id m where
  -- | The type used to represent new records or updates to existing
  -- records. Typically, this is missing an @id@ field.
  type ResourceData id :: Type

  -- | The type used to represent existing records.
  type StoredResourceData id :: Type

  listResources ::
    m [StoredResourceData id]
  createResource ::
    ResourceData id ->
    m (Either ValidationError (StoredResourceData id))
  readResource ::
    id ->
    m (Either NotFoundError (StoredResourceData id))
  upsertResource ::
    id ->
    ResourceData id ->
    m (Either ValidationError (CreatedUpdated, StoredResourceData id))
  deleteResource ::
    id ->
    m (Either NotFoundError ())

data NotFoundError = NotFoundError
  deriving (NotFoundError -> NotFoundError -> Bool
(NotFoundError -> NotFoundError -> Bool)
-> (NotFoundError -> NotFoundError -> Bool) -> Eq NotFoundError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotFoundError -> NotFoundError -> Bool
== :: NotFoundError -> NotFoundError -> Bool
$c/= :: NotFoundError -> NotFoundError -> Bool
/= :: NotFoundError -> NotFoundError -> Bool
Eq, Eq NotFoundError
Eq NotFoundError =>
(NotFoundError -> NotFoundError -> Ordering)
-> (NotFoundError -> NotFoundError -> Bool)
-> (NotFoundError -> NotFoundError -> Bool)
-> (NotFoundError -> NotFoundError -> Bool)
-> (NotFoundError -> NotFoundError -> Bool)
-> (NotFoundError -> NotFoundError -> NotFoundError)
-> (NotFoundError -> NotFoundError -> NotFoundError)
-> Ord NotFoundError
NotFoundError -> NotFoundError -> Bool
NotFoundError -> NotFoundError -> Ordering
NotFoundError -> NotFoundError -> NotFoundError
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 :: NotFoundError -> NotFoundError -> Ordering
compare :: NotFoundError -> NotFoundError -> Ordering
$c< :: NotFoundError -> NotFoundError -> Bool
< :: NotFoundError -> NotFoundError -> Bool
$c<= :: NotFoundError -> NotFoundError -> Bool
<= :: NotFoundError -> NotFoundError -> Bool
$c> :: NotFoundError -> NotFoundError -> Bool
> :: NotFoundError -> NotFoundError -> Bool
$c>= :: NotFoundError -> NotFoundError -> Bool
>= :: NotFoundError -> NotFoundError -> Bool
$cmax :: NotFoundError -> NotFoundError -> NotFoundError
max :: NotFoundError -> NotFoundError -> NotFoundError
$cmin :: NotFoundError -> NotFoundError -> NotFoundError
min :: NotFoundError -> NotFoundError -> NotFoundError
Ord, NotFoundError
NotFoundError -> NotFoundError -> Bounded NotFoundError
forall a. a -> a -> Bounded a
$cminBound :: NotFoundError
minBound :: NotFoundError
$cmaxBound :: NotFoundError
maxBound :: NotFoundError
Bounded, Int -> NotFoundError -> ShowS
[NotFoundError] -> ShowS
NotFoundError -> String
(Int -> NotFoundError -> ShowS)
-> (NotFoundError -> String)
-> ([NotFoundError] -> ShowS)
-> Show NotFoundError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotFoundError -> ShowS
showsPrec :: Int -> NotFoundError -> ShowS
$cshow :: NotFoundError -> String
show :: NotFoundError -> String
$cshowList :: [NotFoundError] -> ShowS
showList :: [NotFoundError] -> ShowS
Show, (forall x. NotFoundError -> Rep NotFoundError x)
-> (forall x. Rep NotFoundError x -> NotFoundError)
-> Generic NotFoundError
forall x. Rep NotFoundError x -> NotFoundError
forall x. NotFoundError -> Rep NotFoundError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NotFoundError -> Rep NotFoundError x
from :: forall x. NotFoundError -> Rep NotFoundError x
$cto :: forall x. Rep NotFoundError x -> NotFoundError
to :: forall x. Rep NotFoundError x -> NotFoundError
Generic)

instance ToJSON NotFoundError where
  toJSON :: NotFoundError -> Value
toJSON NotFoundError
NotFoundError =
    [Pair] -> Value
object
      [ Key
"errors" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"id" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"Not found"]
      ]

-- | ActiveResource errors are a map where the keys name fields from
-- the payload, and the values are lists of errors at that field.
--
-- The 'ToJSON' instance wraps the whole thing in an @{ "errors": ... }@
-- object, to match [ActiveResource's expectations](https://github.com/rails/activeresource/blob/3cf44f731f655dccc13ba23f78603f7e214e3352/lib/active_resource/validations.rb#L35-L71).
newtype ValidationError = ValidationError (Map Text [Text])
  deriving stock (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
/= :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationError -> ShowS
showsPrec :: Int -> ValidationError -> ShowS
$cshow :: ValidationError -> String
show :: ValidationError -> String
$cshowList :: [ValidationError] -> ShowS
showList :: [ValidationError] -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationError -> Rep ValidationError x
from :: forall x. ValidationError -> Rep ValidationError x
$cto :: forall x. Rep ValidationError x -> ValidationError
to :: forall x. Rep ValidationError x -> ValidationError
Generic)

instance ToJSON ValidationError where
  toJSON :: ValidationError -> Value
toJSON (ValidationError Map Text [Text]
errs) = [Pair] -> Value
object [Key
"errors" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Text [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON Map Text [Text]
errs]

data CreatedUpdated = Created | Updated
  deriving (CreatedUpdated -> CreatedUpdated -> Bool
(CreatedUpdated -> CreatedUpdated -> Bool)
-> (CreatedUpdated -> CreatedUpdated -> Bool) -> Eq CreatedUpdated
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CreatedUpdated -> CreatedUpdated -> Bool
== :: CreatedUpdated -> CreatedUpdated -> Bool
$c/= :: CreatedUpdated -> CreatedUpdated -> Bool
/= :: CreatedUpdated -> CreatedUpdated -> Bool
Eq, Eq CreatedUpdated
Eq CreatedUpdated =>
(CreatedUpdated -> CreatedUpdated -> Ordering)
-> (CreatedUpdated -> CreatedUpdated -> Bool)
-> (CreatedUpdated -> CreatedUpdated -> Bool)
-> (CreatedUpdated -> CreatedUpdated -> Bool)
-> (CreatedUpdated -> CreatedUpdated -> Bool)
-> (CreatedUpdated -> CreatedUpdated -> CreatedUpdated)
-> (CreatedUpdated -> CreatedUpdated -> CreatedUpdated)
-> Ord CreatedUpdated
CreatedUpdated -> CreatedUpdated -> Bool
CreatedUpdated -> CreatedUpdated -> Ordering
CreatedUpdated -> CreatedUpdated -> CreatedUpdated
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 :: CreatedUpdated -> CreatedUpdated -> Ordering
compare :: CreatedUpdated -> CreatedUpdated -> Ordering
$c< :: CreatedUpdated -> CreatedUpdated -> Bool
< :: CreatedUpdated -> CreatedUpdated -> Bool
$c<= :: CreatedUpdated -> CreatedUpdated -> Bool
<= :: CreatedUpdated -> CreatedUpdated -> Bool
$c> :: CreatedUpdated -> CreatedUpdated -> Bool
> :: CreatedUpdated -> CreatedUpdated -> Bool
$c>= :: CreatedUpdated -> CreatedUpdated -> Bool
>= :: CreatedUpdated -> CreatedUpdated -> Bool
$cmax :: CreatedUpdated -> CreatedUpdated -> CreatedUpdated
max :: CreatedUpdated -> CreatedUpdated -> CreatedUpdated
$cmin :: CreatedUpdated -> CreatedUpdated -> CreatedUpdated
min :: CreatedUpdated -> CreatedUpdated -> CreatedUpdated
Ord, CreatedUpdated
CreatedUpdated -> CreatedUpdated -> Bounded CreatedUpdated
forall a. a -> a -> Bounded a
$cminBound :: CreatedUpdated
minBound :: CreatedUpdated
$cmaxBound :: CreatedUpdated
maxBound :: CreatedUpdated
Bounded, Int -> CreatedUpdated -> ShowS
[CreatedUpdated] -> ShowS
CreatedUpdated -> String
(Int -> CreatedUpdated -> ShowS)
-> (CreatedUpdated -> String)
-> ([CreatedUpdated] -> ShowS)
-> Show CreatedUpdated
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CreatedUpdated -> ShowS
showsPrec :: Int -> CreatedUpdated -> ShowS
$cshow :: CreatedUpdated -> String
show :: CreatedUpdated -> String
$cshowList :: [CreatedUpdated] -> ShowS
showList :: [CreatedUpdated] -> ShowS
Show, (forall x. CreatedUpdated -> Rep CreatedUpdated x)
-> (forall x. Rep CreatedUpdated x -> CreatedUpdated)
-> Generic CreatedUpdated
forall x. Rep CreatedUpdated x -> CreatedUpdated
forall x. CreatedUpdated -> Rep CreatedUpdated x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CreatedUpdated -> Rep CreatedUpdated x
from :: forall x. CreatedUpdated -> Rep CreatedUpdated x
$cto :: forall x. Rep CreatedUpdated x -> CreatedUpdated
to :: forall x. Rep CreatedUpdated x -> CreatedUpdated
Generic)

-- | The CRUDL routes required by an ActiveResource API, using Servant's
-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html generic record-based routing>.
-- Once you have a 'Resource' instance, use 'makeResourceServerT' to
-- generate a server that fills out this structure.
--
-- NOTE: If the
-- <https://github.com/haskell-servant/servant/issues/1466 alternate syntax>
-- for ':-' gets merged, we intend to adopt it; it's easier to read.
data ResourceRoutes (id :: Type) mode = ResourceRoutes
  { forall id mode.
ResourceRoutes id mode
-> mode
   :- UVerb 'GET '[JSON] '[WithStatus 200 [StoredResourceData id]]
listRoute ::
      mode
        :- UVerb 'GET '[JSON] '[WithStatus 200 [StoredResourceData id]],
    forall id mode.
ResourceRoutes id mode
-> mode
   :- (ReqBody '[JSON] (ResourceData id)
       :> UVerb
            'POST
            '[JSON]
            '[WithStatus 422 ValidationError,
              WithStatus 201 (StoredResourceData id)])
createRoute ::
      mode
        :- ( ReqBody '[JSON] (ResourceData id)
               :> UVerb
                    'POST
                    '[JSON]
                    '[ WithStatus 422 ValidationError,
                       WithStatus 201 (StoredResourceData id)
                     ]
           ),
    forall id mode.
ResourceRoutes id mode
-> mode
   :- (Capture "id" id
       :> UVerb
            'GET
            '[JSON]
            '[WithStatus 404 NotFoundError,
              WithStatus 200 (StoredResourceData id)])
readRoute ::
      mode
        :- ( Capture "id" id
               :> UVerb
                    'GET
                    '[JSON]
                    '[ WithStatus 404 NotFoundError,
                       WithStatus 200 (StoredResourceData id)
                     ]
           ),
    forall id mode.
ResourceRoutes id mode
-> mode
   :- (Capture "id" id
       :> (ReqBody '[JSON] (ResourceData id)
           :> UVerb
                'PUT
                '[JSON]
                '[WithStatus 422 ValidationError,
                  WithStatus 200 (StoredResourceData id),
                  WithStatus 201 (StoredResourceData id)]))
upsertRoute ::
      mode
        :- ( Capture "id" id
               :> ReqBody '[JSON] (ResourceData id)
               :> UVerb
                    'PUT
                    '[JSON]
                    '[ WithStatus 422 ValidationError,
                       WithStatus 200 (StoredResourceData id),
                       WithStatus 201 (StoredResourceData id)
                     ]
           ),
    forall id mode.
ResourceRoutes id mode
-> mode
   :- (Capture "id" id
       :> UVerb
            'DELETE
            '[JSON]
            '[WithStatus 404 NotFoundError, WithStatus 204 NoContent])
deleteRoute ::
      mode
        :- ( Capture "id" id
               :> UVerb
                    'DELETE
                    '[JSON]
                    '[ WithStatus 404 NotFoundError,
                       WithStatus 204 NoContent
                     ]
           )
  }
  deriving ((forall x.
 ResourceRoutes id mode -> Rep (ResourceRoutes id mode) x)
-> (forall x.
    Rep (ResourceRoutes id mode) x -> ResourceRoutes id mode)
-> Generic (ResourceRoutes id mode)
forall x. Rep (ResourceRoutes id mode) x -> ResourceRoutes id mode
forall x. ResourceRoutes id mode -> Rep (ResourceRoutes id mode) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall id mode x.
Rep (ResourceRoutes id mode) x -> ResourceRoutes id mode
forall id mode x.
ResourceRoutes id mode -> Rep (ResourceRoutes id mode) x
$cfrom :: forall id mode x.
ResourceRoutes id mode -> Rep (ResourceRoutes id mode) x
from :: forall x. ResourceRoutes id mode -> Rep (ResourceRoutes id mode) x
$cto :: forall id mode x.
Rep (ResourceRoutes id mode) x -> ResourceRoutes id mode
to :: forall x. Rep (ResourceRoutes id mode) x -> ResourceRoutes id mode
Generic)

-- | Given an instance of 'ResourceId ty', plumb through its operations to
-- build a 'ResourceRoutes'. GHC's type checker
-- <https://github.com/haskell-servant/servant/issues/1381 isn't smart enough>
-- to reason through the generated code if it's given a polymorphic
-- type, so we have to use TH.
--
-- If @m ~ ResourceMonad ty@, then you can call it like this:
--
-- @
-- myResourceServer :: 'ResourceRoutes' ty ('Servant.Generic.AsServerT' m)
-- myResourceServer = \$(makeResourceServerT [t|ty|])
-- @
--
-- The generated code will
-- need @-XDataKinds@, @-XLambdaCase@, and @-XTypeApplications@.
--
-- You can then serve it using the functions in "Servant.Server.Generic".
makeResourceServerT :: TH.TypeQ -> TH.ExpQ
makeResourceServerT :: TypeQ -> ExpQ
makeResourceServerT TypeQ
ty =
  [|
    ResourceRoutes
      { listRoute =
          $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|listResources|] TypeQ
ty)
            >>= $(Integer -> ExpQ
respondWithStatus Integer
200),
        createRoute =
          $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|createResource|] TypeQ
ty)
            >=> either $(Integer -> ExpQ
respondWithStatus Integer
422) $(Integer -> ExpQ
respondWithStatus Integer
201),
        readRoute =
          $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|readResource|] TypeQ
ty)
            >=> either $(Integer -> ExpQ
respondWithStatus Integer
404) $(Integer -> ExpQ
respondWithStatus Integer
200),
        upsertRoute = \id_ data_ ->
          $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|upsertResource|] TypeQ
ty) id_ data_
            >>= either
              $(Integer -> ExpQ
respondWithStatus Integer
422)
              ( \case
                  (Created, r) -> $(Integer -> ExpQ
respondWithStatus Integer
201) r
                  (Updated, r) -> $(Integer -> ExpQ
respondWithStatus Integer
200) r
              ),
        deleteRoute =
          $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|deleteResource|] TypeQ
ty)
            >=> either
              $(Integer -> ExpQ
respondWithStatus Integer
404)
              (const ($(Integer -> ExpQ
respondWithStatus Integer
204) NoContent))
      }
    |]
  where
    -- respondWithStatus n ===> respond . WithStatus @n
    respondWithStatus :: Integer -> TH.ExpQ
    respondWithStatus :: Integer -> ExpQ
respondWithStatus Integer
n = [|respond . $(ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
TH.appTypeE [|WithStatus|] (Q TyLit -> TypeQ
forall (m :: * -> *). Quote m => m TyLit -> m Type
TH.litT (Integer -> Q TyLit
forall (m :: * -> *). Quote m => Integer -> m TyLit
TH.numTyLit Integer
n)))|]

-- | This is a custom error formatter for parse errors, which runs when
-- Servant fails to deserialise a request parameter (i.e., before endpoint
-- code runs).
--
-- Technically, such a parse failure should return
-- <https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/400 HTTP 400 Bad Request>,
-- but ActiveResource shows no useful information in such
-- cases. This formatter therefore gives up technical purity in favour of
-- reasonable error messages.
--
-- You can use it with @servant-server@'s various @...WithContext@ functions:
--
-- @
-- -- Supposing our 'ResourceMonad' is servant-server's 'Handler' type, so we
-- -- can pass 'id' as the natural transformation parameter:
-- 'Servant.Server.Generic.genericServeTWithContext' id myResourceServer (errorFormatters ':.' 'EmptyContext')
-- @
errorFormatters :: ErrorFormatters
errorFormatters :: ErrorFormatters
errorFormatters =
  ErrorFormatters
defaultErrorFormatters
    { bodyParserErrorFormatter = \TypeRep
_ Request
req String
err ->
        let value :: Value
value = [Pair] -> Value
object [Key
"id" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [String
err]]
            acceptHeader :: AcceptHeader
acceptHeader = Request -> AcceptHeader
getAcceptHeader Request
req
         in case Proxy '[JSON]
-> AcceptHeader -> Value -> Maybe (ByteString, ByteString)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @'[JSON]) AcceptHeader
acceptHeader Value
value of
              Maybe (ByteString, ByteString)
Nothing -> ServerError
err422 {errBody = BL8.pack err}
              Just (ByteString
contentType, ByteString
body) ->
                ServerError
err422
                  { errBody = body,
                    errHeaders = [("Content-Type", BL.toStrict contentType)]
                  }
    }