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

-- | 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.Aeson (FromJSON, ToJSON)
import Data.Proxy (Proxy (Proxy))
import qualified GHC.Generics as GHC
import GHC.TypeLits (Nat)
import Network.HTTP.Types (Status, StdMethod)
import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)
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)))

instance KnownStatus n => HasStatus (WithStatus n a) where
  type StatusOf (WithStatus n a) = n

-- | 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)

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, (forall x. WithStatus k a -> Rep (WithStatus k a) x)
-> (forall x. Rep (WithStatus k a) x -> WithStatus k a)
-> Generic (WithStatus k a)
forall x. Rep (WithStatus k a) x -> WithStatus k a
forall x. WithStatus k a -> Rep (WithStatus k a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (k :: Nat) a x. Rep (WithStatus k a) x -> WithStatus k a
forall (k :: Nat) a x. WithStatus k a -> Rep (WithStatus k a) x
$cto :: forall (k :: Nat) a x. Rep (WithStatus k a) x -> WithStatus k a
$cfrom :: forall (k :: Nat) a x. WithStatus k a -> Rep (WithStatus k a) x
GHC.Generic)

instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)

instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)

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

-- | 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 :: [*])