{-# 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 (JSON, PlainText, FormUrlEncoded, OctetStream, 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)

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

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

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

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

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

instance {-# OVERLAPPING #-} MimeUnrender JSON a => MimeUnrender JSON (WithStatus _status a) where
  mimeUnrender :: Proxy JSON -> ByteString -> Either String (WithStatus _status a)
mimeUnrender Proxy JSON
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 JSON -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy JSON
contentTypeProxy ByteString
input

instance {-# OVERLAPPING #-} MimeUnrender PlainText a => MimeUnrender PlainText (WithStatus _status a) where
  mimeUnrender :: Proxy PlainText
-> ByteString -> Either String (WithStatus _status a)
mimeUnrender Proxy PlainText
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 PlainText -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy PlainText
contentTypeProxy ByteString
input

instance {-# OVERLAPPING #-} MimeUnrender FormUrlEncoded a => MimeUnrender FormUrlEncoded (WithStatus _status a) where
  mimeUnrender :: Proxy FormUrlEncoded
-> ByteString -> Either String (WithStatus _status a)
mimeUnrender Proxy FormUrlEncoded
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 FormUrlEncoded -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy FormUrlEncoded
contentTypeProxy ByteString
input

instance {-# OVERLAPPING #-} MimeUnrender OctetStream a => MimeUnrender OctetStream (WithStatus _status a) where
  mimeUnrender :: Proxy OctetStream
-> ByteString -> Either String (WithStatus _status a)
mimeUnrender Proxy OctetStream
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 OctetStream -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy OctetStream
contentTypeProxy ByteString
input