{-# LANGUAGE ApplicativeDo #-}
module Servant.Client.Core.MultiVerb.ResponseUnrender where

import Control.Applicative
import Control.Monad
import Data.Kind (Type)
import Data.SOP
import Data.Typeable
import GHC.TypeLits
import Network.HTTP.Types.Status (Status)
import qualified Data.ByteString.Lazy as BSL
import qualified Network.HTTP.Media as M

import Servant.API.ContentTypes
import Servant.API.MultiVerb
import Servant.API.Status
import Servant.API.UVerb.Union (Union)
import Servant.Client.Core.Response (ResponseF(..))
import qualified Servant.Client.Core.Response as Response
import Servant.API.Stream (SourceIO)
import Data.ByteString (ByteString)

data SomeClientResponse = forall a. Typeable a => SomeClientResponse (ResponseF a)

fromSomeClientResponse 
  :: forall a m. (Alternative m, Typeable a)
  => SomeClientResponse
  -> m (ResponseF a)
fromSomeClientResponse :: forall a (m :: Type -> Type).
(Alternative m, Typeable a) =>
SomeClientResponse -> m (ResponseF a)
fromSomeClientResponse (SomeClientResponse Response {a
Seq Header
Status
HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseBody :: a
responseBody :: forall a. ResponseF a -> a
responseHeaders :: forall a. ResponseF a -> Seq Header
responseHttpVersion :: forall a. ResponseF a -> HttpVersion
responseStatusCode :: forall a. ResponseF a -> Status
..}) = do
  a
body <- m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall a. m a
forall (f :: Type -> Type) a. Alternative f => f a
empty a -> m a
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe a -> m a) -> Maybe a -> m a
forall a b. (a -> b) -> a -> b
$ forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast @_ @a a
responseBody
  pure $
    Response
      { responseBody :: a
responseBody = a
body,
        Seq Header
Status
HttpVersion
responseStatusCode :: Status
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseHeaders :: Seq Header
responseHttpVersion :: HttpVersion
responseStatusCode :: Status
..
      }

class ResponseUnrender cs a where
  type ResponseBody a :: Type
  type ResponseStatus a :: Nat
  responseUnrender
    :: M.MediaType
    -> ResponseF (ResponseBody a)
    -> UnrenderResult (ResponseType a)

class (Typeable as) => ResponseListUnrender cs as where
  responseListUnrender
    :: M.MediaType
    -> SomeClientResponse
    -> UnrenderResult (Union (ResponseTypes as))

  responseListStatuses :: [Status]

instance ResponseListUnrender cs '[] where
  responseListUnrender :: MediaType
-> SomeClientResponse -> UnrenderResult (Union (ResponseTypes '[]))
responseListUnrender MediaType
_ SomeClientResponse
_ = UnrenderResult (Union '[])
UnrenderResult (Union (ResponseTypes '[]))
forall a. UnrenderResult a
StatusMismatch
  responseListStatuses :: [Status]
responseListStatuses = []

instance
  ( Typeable a,
    Typeable (ResponseBody a),
    ResponseUnrender cs a,
    ResponseListUnrender cs as,
    KnownStatus (ResponseStatus a)
  ) =>
  ResponseListUnrender cs (a ': as)
  where
  responseListUnrender :: MediaType
-> SomeClientResponse
-> UnrenderResult (Union (ResponseTypes (a : as)))
responseListUnrender MediaType
c SomeClientResponse
output =
    I (ResponseType a) -> NS I (ResponseType a : ResponseTypes as)
forall {k} (a :: k -> Type) (x :: k) (xs :: [k]).
a x -> NS a (x : xs)
Z (I (ResponseType a) -> NS I (ResponseType a : ResponseTypes as))
-> (ResponseType a -> I (ResponseType a))
-> ResponseType a
-> NS I (ResponseType a : ResponseTypes as)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseType a -> I (ResponseType a)
forall a. a -> I a
I (ResponseType a -> NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (ResponseType a)
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (cs :: k) a.
ResponseUnrender cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
forall {k} (cs :: k) a.
ResponseUnrender cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
responseUnrender @cs @a MediaType
c (ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a))
-> UnrenderResult (ResponseF (ResponseBody a))
-> UnrenderResult (ResponseType a)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeClientResponse -> UnrenderResult (ResponseF (ResponseBody a))
forall a (m :: Type -> Type).
(Alternative m, Typeable a) =>
SomeClientResponse -> m (ResponseF a)
fromSomeClientResponse SomeClientResponse
output)
      UnrenderResult (NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall a. UnrenderResult a -> UnrenderResult a -> UnrenderResult a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> NS I (ResponseTypes as) -> NS I (ResponseType a : ResponseTypes as)
forall {k} (a :: k -> Type) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS I (ResponseTypes as)
 -> NS I (ResponseType a : ResponseTypes as))
-> UnrenderResult (NS I (ResponseTypes as))
-> UnrenderResult (NS I (ResponseType a : ResponseTypes as))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (cs :: k) (as :: [Type]).
ResponseListUnrender cs as =>
MediaType
-> SomeClientResponse -> UnrenderResult (Union (ResponseTypes as))
forall {k} (cs :: k) (as :: [Type]).
ResponseListUnrender cs as =>
MediaType
-> SomeClientResponse -> UnrenderResult (Union (ResponseTypes as))
responseListUnrender @cs @as MediaType
c SomeClientResponse
output

  responseListStatuses :: [Status]
responseListStatuses = Proxy (ResponseStatus a) -> Status
forall (n :: Nat) (proxy :: Nat -> Type).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> Type). proxy (ResponseStatus a) -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ResponseStatus a)) Status -> [Status] -> [Status]
forall a. a -> [a] -> [a]
: forall (cs :: k) (as :: [Type]).
ResponseListUnrender cs as =>
[Status]
forall {k} (cs :: k) (as :: [Type]).
ResponseListUnrender cs as =>
[Status]
responseListStatuses @cs @as

instance
  ( KnownStatus s,
    MimeUnrender ct a
  ) =>
  ResponseUnrender cs (RespondAs (ct :: Type) s desc a)
  where
  type ResponseStatus (RespondAs ct s desc a) = s
  type ResponseBody (RespondAs ct s desc a) = BSL.ByteString

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondAs ct s desc a))
-> UnrenderResult (ResponseType (RespondAs ct s desc a))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondAs ct s desc a))
output = do
    Bool -> UnrenderResult ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ResponseF ByteString -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF ByteString
ResponseF (ResponseBody (RespondAs ct s desc a))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> Type).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> Type). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    (String -> UnrenderResult a)
-> (a -> UnrenderResult a) -> Either String a -> UnrenderResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError a -> UnrenderResult a
forall a. a -> UnrenderResult a
UnrenderSuccess (Either String a -> UnrenderResult a)
-> Either String a -> UnrenderResult a
forall a b. (a -> b) -> a -> b
$
      Proxy ct -> ByteString -> Either String a
forall {k} (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ct) (ResponseF ByteString -> ByteString
forall a. ResponseF a -> a
Response.responseBody ResponseF ByteString
ResponseF (ResponseBody (RespondAs ct s desc a))
output)

instance (KnownStatus s) => ResponseUnrender cs (RespondAs '() s desc ()) where
  type ResponseStatus (RespondAs '() s desc ()) = s
  type ResponseBody (RespondAs '() s desc ()) = ()

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondAs '() s desc ()))
-> UnrenderResult (ResponseType (RespondAs '() s desc ()))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondAs '() s desc ()))
output =
    Bool -> UnrenderResult ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ResponseF () -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF ()
ResponseF (ResponseBody (RespondAs '() s desc ()))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> Type).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> Type). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))

instance
  (KnownStatus s) 
  => ResponseUnrender cs (RespondStreaming s desc framing ct)
  where
  type ResponseStatus (RespondStreaming s desc framing ct) = s
  type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (RespondStreaming s desc framing ct))
-> UnrenderResult
     (ResponseType (RespondStreaming s desc framing ct))
responseUnrender MediaType
_ ResponseF (ResponseBody (RespondStreaming s desc framing ct))
resp = do
    Bool -> UnrenderResult ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ResponseF (SourceIO ByteString) -> Status
forall a. ResponseF a -> Status
Response.responseStatusCode ResponseF (SourceIO ByteString)
ResponseF (ResponseBody (RespondStreaming s desc framing ct))
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> Type).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> Type). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    pure $ ResponseF (SourceIO ByteString) -> SourceIO ByteString
forall a. ResponseF a -> a
Response.responseBody ResponseF (SourceIO ByteString)
ResponseF (ResponseBody (RespondStreaming s desc framing ct))
resp

instance
  (AllMimeUnrender cs a, KnownStatus s)
  => ResponseUnrender cs (Respond s desc a) where
  type ResponseStatus (Respond s desc a) = s
  type ResponseBody (Respond s desc a) = BSL.ByteString

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (Respond s desc a))
-> UnrenderResult (ResponseType (Respond s desc a))
responseUnrender MediaType
c ResponseF (ResponseBody (Respond s desc a))
output = do
    Bool -> UnrenderResult ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ResponseF ByteString -> Status
forall a. ResponseF a -> Status
responseStatusCode ResponseF ByteString
ResponseF (ResponseBody (Respond s desc a))
output Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy s -> Status
forall (n :: Nat) (proxy :: Nat -> Type).
KnownStatus n =>
proxy n -> Status
forall (proxy :: Nat -> Type). proxy s -> Status
statusVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s))
    let results :: [(MediaType, ByteString -> Either String a)]
results = Proxy cs -> [(MediaType, ByteString -> Either String a)]
forall (list :: [Type]) a.
AllMimeUnrender list a =>
Proxy list -> [(MediaType, ByteString -> Either String a)]
allMimeUnrender (forall (t :: [Type]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @cs)
    case MediaType
-> [(MediaType, ByteString -> Either String a)]
-> Maybe (ByteString -> Either String a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup MediaType
c [(MediaType, ByteString -> Either String a)]
results of
      Maybe (ByteString -> Either String a)
Nothing -> UnrenderResult a
forall a. UnrenderResult a
forall (f :: Type -> Type) a. Alternative f => f a
empty
      Just ByteString -> Either String a
f -> (String -> UnrenderResult a)
-> (a -> UnrenderResult a) -> Either String a -> UnrenderResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError a -> UnrenderResult a
forall a. a -> UnrenderResult a
UnrenderSuccess (ByteString -> Either String a
f (ResponseF ByteString -> ByteString
forall a. ResponseF a -> a
responseBody ResponseF ByteString
ResponseF (ResponseBody (Respond s desc a))
output))

instance
  ( AsHeaders xs (ResponseType r) a,
    ServantHeaders hs xs,
    ResponseUnrender cs r
  ) =>
  ResponseUnrender cs (WithHeaders hs a r)
  where
  type ResponseStatus (WithHeaders hs a r) = ResponseStatus r
  type ResponseBody (WithHeaders hs a r) = ResponseBody r

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (WithHeaders hs a r))
-> UnrenderResult (ResponseType (WithHeaders hs a r))
responseUnrender MediaType
c ResponseF (ResponseBody (WithHeaders hs a r))
output = do
    ResponseType r
x <- forall (cs :: k) a.
ResponseUnrender cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
forall {k} (cs :: k) a.
ResponseUnrender cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
responseUnrender @cs @r MediaType
c ResponseF (ResponseBody r)
ResponseF (ResponseBody (WithHeaders hs a r))
output
    case forall (headers :: [Type]) (xs :: [Type]).
ServantHeaders headers xs =>
Seq Header -> Maybe (NP I xs)
forall {k} (headers :: k) (xs :: [Type]).
ServantHeaders headers xs =>
Seq Header -> Maybe (NP I xs)
extractHeaders @hs (ResponseF (ResponseBody r) -> Seq Header
forall a. ResponseF a -> Seq Header
responseHeaders ResponseF (ResponseBody r)
ResponseF (ResponseBody (WithHeaders hs a r))
output) of
      Maybe (NP I xs)
Nothing -> String -> UnrenderResult a
forall a. String -> UnrenderResult a
UnrenderError String
"Failed to parse headers"
      Just NP I xs
hs -> a -> UnrenderResult a
forall a. a -> UnrenderResult a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a -> UnrenderResult a) -> a -> UnrenderResult a
forall a b. (a -> b) -> a -> b
$ forall (headers :: [Type]) response returnType.
AsHeaders headers response returnType =>
(NP I headers, response) -> returnType
fromHeaders @xs (NP I xs
hs, ResponseType r
x)