{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an
-- open union of types, and specific status codes for each type in this union.  (`UVerb` is
-- short for `UnionVerb`)
--
-- This can be used for returning (rather than throwing) exceptions in a server as in, say
-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or
-- 201 created with a different body type, depending on the circumstances.  (All of this can
-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in
-- the API types without something like `UVerb`.)
--
-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.
module Servant.API.UVerb
  ( UVerb,
    HasStatus (StatusOf),
    statusOf,
    HasStatuses (Statuses, statuses),
    WithStatus (..),
    module Servant.API.UVerb.Union,
  )
where

import Data.Proxy (Proxy (Proxy))
import GHC.TypeLits (Nat)
import Network.HTTP.Types (Status, StdMethod)
import Servant.API.ContentTypes (NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender))
import Servant.API.Status (KnownStatus, statusVal)
import Servant.API.UVerb.Union

class KnownStatus (StatusOf a) => HasStatus (a :: *) where
  type StatusOf (a :: *) :: Nat

statusOf :: forall a proxy. HasStatus a => proxy a -> Status
statusOf :: proxy a -> Status
statusOf = Status -> proxy a -> Status
forall a b. a -> b -> a
const (Proxy (StatusOf a) -> Status
forall (n :: Nat) (proxy :: Nat -> *).
KnownStatus n =>
proxy n -> Status
statusVal (Proxy (StatusOf a)
forall k (t :: k). Proxy t
Proxy :: Proxy (StatusOf a)))

-- | If an API can respond with 'NoContent' we assume that this will happen
-- with the status code 204 No Content. If this needs to be overridden,
-- 'WithStatus' can be used.
instance HasStatus NoContent where
  type StatusOf NoContent = 204

class HasStatuses (as :: [*]) where
  type Statuses (as :: [*]) :: [Nat]
  statuses :: Proxy as -> [Status]

instance HasStatuses '[] where
  type Statuses '[] = '[]
  statuses :: Proxy '[] -> [Status]
statuses Proxy '[]
_ = []

instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where
  type Statuses (a ': as) = StatusOf a ': Statuses as
  statuses :: Proxy (a : as) -> [Status]
statuses Proxy (a : as)
_ = Proxy a -> Status
forall a (proxy :: * -> *). HasStatus a => proxy a -> Status
statusOf (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) Status -> [Status] -> [Status]
forall a. a -> [a] -> [a]
: Proxy as -> [Status]
forall (as :: [*]). HasStatuses as => Proxy as -> [Status]
statuses (Proxy as
forall k (t :: k). Proxy t
Proxy :: Proxy as)

-- | A simple newtype wrapper that pairs a type with its status code.  It
-- implements all the content types that Servant ships with by default.
newtype WithStatus (k :: Nat) a = WithStatus a
  deriving (WithStatus k a -> WithStatus k a -> Bool
(WithStatus k a -> WithStatus k a -> Bool)
-> (WithStatus k a -> WithStatus k a -> Bool)
-> Eq (WithStatus k a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (k :: Nat) a.
Eq a =>
WithStatus k a -> WithStatus k a -> Bool
/= :: WithStatus k a -> WithStatus k a -> Bool
$c/= :: forall (k :: Nat) a.
Eq a =>
WithStatus k a -> WithStatus k a -> Bool
== :: WithStatus k a -> WithStatus k a -> Bool
$c== :: forall (k :: Nat) a.
Eq a =>
WithStatus k a -> WithStatus k a -> Bool
Eq, Int -> WithStatus k a -> ShowS
[WithStatus k a] -> ShowS
WithStatus k a -> String
(Int -> WithStatus k a -> ShowS)
-> (WithStatus k a -> String)
-> ([WithStatus k a] -> ShowS)
-> Show (WithStatus k a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (k :: Nat) a. Show a => Int -> WithStatus k a -> ShowS
forall (k :: Nat) a. Show a => [WithStatus k a] -> ShowS
forall (k :: Nat) a. Show a => WithStatus k a -> String
showList :: [WithStatus k a] -> ShowS
$cshowList :: forall (k :: Nat) a. Show a => [WithStatus k a] -> ShowS
show :: WithStatus k a -> String
$cshow :: forall (k :: Nat) a. Show a => WithStatus k a -> String
showsPrec :: Int -> WithStatus k a -> ShowS
$cshowsPrec :: forall (k :: Nat) a. Show a => Int -> WithStatus k a -> ShowS
Show)

instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where
  mimeRender :: Proxy ctype -> WithStatus _status a -> ByteString
mimeRender Proxy ctype
contentTypeProxy (WithStatus a
a) = Proxy ctype -> a -> ByteString
forall k (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctype
contentTypeProxy a
a

instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
  mimeUnrender :: Proxy ctype -> ByteString -> Either String (WithStatus _status a)
mimeUnrender Proxy ctype
contentTypeProxy ByteString
input =
    a -> WithStatus _status a
forall (k :: Nat) a. a -> WithStatus k a
WithStatus (a -> WithStatus _status a)
-> Either String a -> Either String (WithStatus _status a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy ctype -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy ctype
contentTypeProxy ByteString
input

-- | an instance of this typeclass assigns a HTTP status code to a return type
--
-- Example:
--
-- @
--    data NotFoundError = NotFoundError String
--
--    instance HasStatus NotFoundError where
--      type StatusOf NotFoundError = 404
-- @
--
-- You can also use the convience newtype wrapper 'WithStatus' if you want to
-- avoid writing a 'HasStatus' instance manually. It also has the benefit of
-- showing the status code in the type; which might aid in readability.
instance KnownStatus n => HasStatus (WithStatus n a) where
  type StatusOf (WithStatus n a) = n


-- | A variant of 'Verb' that can have any of a number of response values and status codes.
--
-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write
-- instances for 'HasServer' etc. for the latter, getting them for the former for free.
-- Something like:
--
-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@
--
-- Backwards compatibility is tricky, though: this type alias would mean people would have to
-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.
data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])