{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_HADDOCK not-home       #-}

-- | A collection of basic Content-Types (also known as Internet Media
-- Types, or MIME types). Additionally, this module provides classes that
-- encapsulate how to serialize or deserialize values to or from
-- a particular Content-Type.
--
-- Content-Types are used in `ReqBody` and the method combinators:
--
-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
--
-- Meaning the endpoint accepts requests of Content-Type @application/json@
-- or @text/plain;charset-utf8@, and returns data in either one of those
-- formats (depending on the @Accept@ header).
--
-- If you would like to support Content-Types beyond those provided here,
-- then:
--
--      (1) Declare a new data type with no constructors (e.g. @data HTML@).
--      (2) Make an instance of it for `Accept`.
--      (3) If you want to be able to serialize data *into* that
--      Content-Type, make an instance of it for `MimeRender`.
--      (4) If you want to be able to deserialize data *from* that
--      Content-Type, make an instance of it for `MimeUnrender`.
--
-- Note that roles are reversed in @servant-server@ and @servant-client@:
-- to be able to serve (or even typecheck) a @Get '[JSON, XML] MyData@,
-- you'll need to have the appropriate `MimeRender` instances in scope,
-- whereas to query that endpoint with @servant-client@, you'll need
-- a `MimeUnrender` instance in scope.
module Servant.API.ContentTypes
    (
    -- * Provided Content-Types
      JSON
    , PlainText
    , FormUrlEncoded
    , OctetStream

    -- * Building your own Content-Type
    , Accept(..)
    , MimeRender(..)
    , MimeUnrender(..)

    -- * NoContent
    , NoContent(..)

    -- * Internal
    , AcceptHeader(..)
    , AllCTRender(..)
    , AllCTUnrender(..)
    , AllMime(..)
    , AllMimeRender(..)
    , AllMimeUnrender(..)
    , eitherDecodeLenient
    , canHandleAcceptH
    ) where

import           Control.Arrow
                 (left)
import           Control.Monad.Compat
import           Control.DeepSeq
                 (NFData)
import           Data.Aeson
                 (FromJSON (..), ToJSON (..), encode)
import           Data.Aeson.Parser
                 (value)
import           Data.Aeson.Types
                 (parseEither)
import           Data.Attoparsec.ByteString.Char8
                 (endOfInput, parseOnly, skipSpace, (<?>))
import qualified Data.ByteString                  as BS
import           Data.ByteString.Lazy
                 (ByteString, fromStrict, toStrict)
import qualified Data.ByteString.Lazy.Char8       as BC
import qualified Data.List.NonEmpty               as NE
import           Data.Maybe
                 (isJust)
import           Data.String.Conversions
                 (cs)
import qualified Data.Text                        as TextS
import qualified Data.Text.Encoding               as TextS
import qualified Data.Text.Lazy                   as TextL
import qualified Data.Text.Lazy.Encoding          as TextL
import           Data.Typeable
import           GHC.Generics
                 (Generic)
import qualified GHC.TypeLits                     as TL
import qualified Network.HTTP.Media               as M
import           Prelude ()
import           Prelude.Compat
import           Web.FormUrlEncoded
                 (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm)

-- * Provided content types
data JSON deriving Typeable
data PlainText deriving Typeable
data FormUrlEncoded deriving Typeable
data OctetStream deriving Typeable

-- * Accept class

-- | Instances of 'Accept' represent mimetypes. They are used for matching
-- against the @Accept@ HTTP header of the request, and for setting the
-- @Content-Type@ header of the response
--
-- Example:
--
-- >>> import Network.HTTP.Media ((//), (/:))
-- >>> data HTML
-- >>> :{
--instance Accept HTML where
--    contentType _ = "text" // "html" /: ("charset", "utf-8")
-- :}
--
class Accept ctype where
    contentType   :: Proxy ctype -> M.MediaType
    contentType = NonEmpty MediaType -> MediaType
forall a. NonEmpty a -> a
NE.head (NonEmpty MediaType -> MediaType)
-> (Proxy ctype -> NonEmpty MediaType) -> Proxy ctype -> MediaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ctype -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes

    contentTypes  :: Proxy ctype -> NE.NonEmpty M.MediaType
    contentTypes  =  (MediaType -> [MediaType] -> NonEmpty MediaType
forall a. a -> [a] -> NonEmpty a
NE.:| []) (MediaType -> NonEmpty MediaType)
-> (Proxy ctype -> MediaType) -> Proxy ctype -> NonEmpty MediaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy ctype -> MediaType
forall k (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType

    {-# MINIMAL contentType | contentTypes #-}

-- | @application/json@
instance Accept JSON where
    contentTypes :: Proxy JSON -> NonEmpty MediaType
contentTypes Proxy JSON
_ =
      ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"json" MediaType -> (ByteString, ByteString) -> MediaType
M./: (ByteString
"charset", ByteString
"utf-8") MediaType -> [MediaType] -> NonEmpty MediaType
forall a. a -> [a] -> NonEmpty a
NE.:|
      [ ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"json" ]

-- | @application/x-www-form-urlencoded@
instance Accept FormUrlEncoded where
    contentType :: Proxy FormUrlEncoded -> MediaType
contentType Proxy FormUrlEncoded
_ = ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"x-www-form-urlencoded"

-- | @text/plain;charset=utf-8@
instance Accept PlainText where
    contentType :: Proxy PlainText -> MediaType
contentType Proxy PlainText
_ = ByteString
"text" ByteString -> ByteString -> MediaType
M.// ByteString
"plain" MediaType -> (ByteString, ByteString) -> MediaType
M./: (ByteString
"charset", ByteString
"utf-8")

-- | @application/octet-stream@
instance Accept OctetStream where
    contentType :: Proxy OctetStream -> MediaType
contentType Proxy OctetStream
_ = ByteString
"application" ByteString -> ByteString -> MediaType
M.// ByteString
"octet-stream"

newtype AcceptHeader = AcceptHeader BS.ByteString
    deriving (AcceptHeader -> AcceptHeader -> Bool
(AcceptHeader -> AcceptHeader -> Bool)
-> (AcceptHeader -> AcceptHeader -> Bool) -> Eq AcceptHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AcceptHeader -> AcceptHeader -> Bool
$c/= :: AcceptHeader -> AcceptHeader -> Bool
== :: AcceptHeader -> AcceptHeader -> Bool
$c== :: AcceptHeader -> AcceptHeader -> Bool
Eq, Int -> AcceptHeader -> ShowS
[AcceptHeader] -> ShowS
AcceptHeader -> String
(Int -> AcceptHeader -> ShowS)
-> (AcceptHeader -> String)
-> ([AcceptHeader] -> ShowS)
-> Show AcceptHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AcceptHeader] -> ShowS
$cshowList :: [AcceptHeader] -> ShowS
show :: AcceptHeader -> String
$cshow :: AcceptHeader -> String
showsPrec :: Int -> AcceptHeader -> ShowS
$cshowsPrec :: Int -> AcceptHeader -> ShowS
Show, ReadPrec [AcceptHeader]
ReadPrec AcceptHeader
Int -> ReadS AcceptHeader
ReadS [AcceptHeader]
(Int -> ReadS AcceptHeader)
-> ReadS [AcceptHeader]
-> ReadPrec AcceptHeader
-> ReadPrec [AcceptHeader]
-> Read AcceptHeader
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AcceptHeader]
$creadListPrec :: ReadPrec [AcceptHeader]
readPrec :: ReadPrec AcceptHeader
$creadPrec :: ReadPrec AcceptHeader
readList :: ReadS [AcceptHeader]
$creadList :: ReadS [AcceptHeader]
readsPrec :: Int -> ReadS AcceptHeader
$creadsPrec :: Int -> ReadS AcceptHeader
Read, Typeable, (forall x. AcceptHeader -> Rep AcceptHeader x)
-> (forall x. Rep AcceptHeader x -> AcceptHeader)
-> Generic AcceptHeader
forall x. Rep AcceptHeader x -> AcceptHeader
forall x. AcceptHeader -> Rep AcceptHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AcceptHeader x -> AcceptHeader
$cfrom :: forall x. AcceptHeader -> Rep AcceptHeader x
Generic)

-- * Render (serializing)

-- | Instantiate this class to register a way of serializing a type based
-- on the @Accept@ header.
--
-- Example:
--
-- > data MyContentType
-- >
-- > instance Accept MyContentType where
-- >    contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
-- >
-- > instance Show a => MimeRender MyContentType a where
-- >    mimeRender _ val = pack ("This is MINE! " ++ show val)
-- >
-- > type MyAPI = "path" :> Get '[MyContentType] Int
--
class Accept ctype => MimeRender ctype a where
    mimeRender  :: Proxy ctype -> a -> ByteString

class (AllMime list) => AllCTRender (list :: [*]) a where
    -- If the Accept header can be matched, returns (Just) a tuple of the
    -- Content-Type and response (serialization of @a@ into the appropriate
    -- mimetype).
    handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)

instance {-# OVERLAPPABLE #-}
         (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
    handleAcceptH :: Proxy (ct : cts)
-> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy (ct : cts)
_ (AcceptHeader ByteString
accept) a
val = [(MediaType, (ByteString, ByteString))]
-> ByteString -> Maybe (ByteString, ByteString)
forall b. [(MediaType, b)] -> ByteString -> Maybe b
M.mapAcceptMedia [(MediaType, (ByteString, ByteString))]
lkup ByteString
accept
      where pctyps :: Proxy (ct : cts)
pctyps = Proxy (ct : cts)
forall k (t :: k). Proxy t
Proxy :: Proxy (ct ': cts)
            amrs :: [(MediaType, ByteString)]
amrs = Proxy (ct : cts) -> a -> [(MediaType, ByteString)]
forall (list :: [*]) a.
AllMimeRender list a =>
Proxy list -> a -> [(MediaType, ByteString)]
allMimeRender Proxy (ct : cts)
pctyps a
val
            lkup :: [(MediaType, (ByteString, ByteString))]
lkup = ((MediaType, ByteString) -> (MediaType, (ByteString, ByteString)))
-> [(MediaType, ByteString)]
-> [(MediaType, (ByteString, ByteString))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(MediaType
a,ByteString
b) -> (MediaType
a, (ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
M.renderHeader MediaType
a, ByteString
b))) [(MediaType, ByteString)]
amrs

instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.")
  => AllCTRender '[] () where
  handleAcceptH :: Proxy '[] -> AcceptHeader -> () -> Maybe (ByteString, ByteString)
handleAcceptH Proxy '[]
_ AcceptHeader
_ ()
_ = String -> Maybe (ByteString, ByteString)
forall a. HasCallStack => String -> a
error String
"unreachable"

--------------------------------------------------------------------------
-- * Unrender

-- | Instantiate this class to register a way of deserializing a type based
-- on the request's @Content-Type@ header.
--
-- >>> import Network.HTTP.Media hiding (Accept)
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSC
-- >>> data MyContentType = MyContentType String
--
-- >>> :{
--instance Accept MyContentType where
--    contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
-- :}
--
-- >>> :{
--instance Read a => MimeUnrender MyContentType a where
--    mimeUnrender _ bs = case BSC.take 12 bs of
--      "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs
--      _ -> Left "didn't start with the magic incantation"
-- :}
--
-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int
--
class Accept ctype => MimeUnrender ctype a where
    mimeUnrender :: Proxy ctype -> ByteString -> Either String a
    mimeUnrender Proxy ctype
p = Proxy ctype -> MediaType -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> MediaType -> ByteString -> Either String a
mimeUnrenderWithType Proxy ctype
p (Proxy ctype -> MediaType
forall k (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType Proxy ctype
p)

    -- | Variant which is given the actual 'M.MediaType' provided by the other party.
    --
    -- In the most cases you don't want to branch based on the 'M.MediaType'.
    -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
    mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a
    mimeUnrenderWithType Proxy ctype
p MediaType
_ = Proxy ctype -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> ByteString -> Either String a
mimeUnrender Proxy ctype
p

    {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}

class AllCTUnrender (list :: [*]) a where
    canHandleCTypeH
        :: Proxy list
        -> ByteString  -- Content-Type header
        -> Maybe (ByteString -> Either String a)

    handleCTypeH :: Proxy list
                 -> ByteString     -- Content-Type header
                 -> ByteString     -- Request body
                 -> Maybe (Either String a)
    handleCTypeH Proxy list
p ByteString
ctypeH ByteString
body = ((ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ ByteString
body) ((ByteString -> Either String a) -> Either String a)
-> Maybe (ByteString -> Either String a) -> Maybe (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
forall (list :: [*]) a.
AllCTUnrender list a =>
Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH Proxy list
p ByteString
ctypeH

instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
    canHandleCTypeH :: Proxy ctyps -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH Proxy ctyps
p ByteString
ctypeH =
        [(MediaType, ByteString -> Either String a)]
-> ByteString -> Maybe (ByteString -> Either String a)
forall b. [(MediaType, b)] -> ByteString -> Maybe b
M.mapContentMedia (Proxy ctyps -> [(MediaType, ByteString -> Either String a)]
forall (list :: [*]) a.
AllMimeUnrender list a =>
Proxy list -> [(MediaType, ByteString -> Either String a)]
allMimeUnrender Proxy ctyps
p) (ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
ctypeH)

--------------------------------------------------------------------------
-- * Utils (Internal)

class AllMime (list :: [*]) where
    allMime :: Proxy list -> [M.MediaType]

instance AllMime '[] where
    allMime :: Proxy '[] -> [MediaType]
allMime Proxy '[]
_ = []

instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
    allMime :: Proxy (ctyp : ctyps) -> [MediaType]
allMime Proxy (ctyp : ctyps)
_ = NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (Proxy ctyp -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes Proxy ctyp
pctyp) [MediaType] -> [MediaType] -> [MediaType]
forall a. [a] -> [a] -> [a]
++ Proxy ctyps -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime Proxy ctyps
pctyps
      where
        pctyp :: Proxy ctyp
pctyp  = Proxy ctyp
forall k (t :: k). Proxy t
Proxy :: Proxy ctyp
        pctyps :: Proxy ctyps
pctyps = Proxy ctyps
forall k (t :: k). Proxy t
Proxy :: Proxy ctyps

canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
canHandleAcceptH :: Proxy list -> AcceptHeader -> Bool
canHandleAcceptH Proxy list
p (AcceptHeader ByteString
h ) = Maybe MediaType -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MediaType -> Bool) -> Maybe MediaType -> Bool
forall a b. (a -> b) -> a -> b
$ [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
M.matchAccept (Proxy list -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime Proxy list
p) ByteString
h

--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeRender
--------------------------------------------------------------------------
class (AllMime list) => AllMimeRender (list :: [*]) a where
    allMimeRender :: Proxy list
                  -> a                              -- value to serialize
                  -> [(M.MediaType, ByteString)]    -- content-types/response pairs

instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
    allMimeRender :: Proxy '[ctyp] -> a -> [(MediaType, ByteString)]
allMimeRender Proxy '[ctyp]
_ a
a = (MediaType -> (MediaType, ByteString))
-> [MediaType] -> [(MediaType, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (, ByteString
bs) ([MediaType] -> [(MediaType, ByteString)])
-> [MediaType] -> [(MediaType, ByteString)]
forall a b. (a -> b) -> a -> b
$ NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Proxy ctyp -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes Proxy ctyp
pctyp
      where
        bs :: ByteString
bs    = Proxy ctyp -> a -> ByteString
forall k (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctyp
pctyp a
a
        pctyp :: Proxy ctyp
pctyp = Proxy ctyp
forall k (t :: k). Proxy t
Proxy :: Proxy ctyp

instance {-# OVERLAPPABLE #-}
         ( MimeRender ctyp a
         , AllMimeRender (ctyp' ': ctyps) a
         ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
    allMimeRender :: Proxy (ctyp : ctyp' : ctyps) -> a -> [(MediaType, ByteString)]
allMimeRender Proxy (ctyp : ctyp' : ctyps)
_ a
a =
        (MediaType -> (MediaType, ByteString))
-> [MediaType] -> [(MediaType, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (, ByteString
bs) (NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Proxy ctyp -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes Proxy ctyp
pctyp)
        [(MediaType, ByteString)]
-> [(MediaType, ByteString)] -> [(MediaType, ByteString)]
forall a. [a] -> [a] -> [a]
++ Proxy (ctyp' : ctyps) -> a -> [(MediaType, ByteString)]
forall (list :: [*]) a.
AllMimeRender list a =>
Proxy list -> a -> [(MediaType, ByteString)]
allMimeRender Proxy (ctyp' : ctyps)
pctyps a
a
      where
        bs :: ByteString
bs     = Proxy ctyp -> a -> ByteString
forall k (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctyp
pctyp a
a
        pctyp :: Proxy ctyp
pctyp  = Proxy ctyp
forall k (t :: k). Proxy t
Proxy :: Proxy ctyp
        pctyps :: Proxy (ctyp' : ctyps)
pctyps = Proxy (ctyp' : ctyps)
forall k (t :: k). Proxy t
Proxy :: Proxy (ctyp' ': ctyps)


-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
-- then this would be taken care of. However there is no more specific instance
-- between that and 'MimeRender JSON a', so we do this instead
instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
    allMimeRender :: Proxy '[ctyp] -> NoContent -> [(MediaType, ByteString)]
allMimeRender Proxy '[ctyp]
_ NoContent
_ = (MediaType -> (MediaType, ByteString))
-> [MediaType] -> [(MediaType, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (, ByteString
"") ([MediaType] -> [(MediaType, ByteString)])
-> [MediaType] -> [(MediaType, ByteString)]
forall a b. (a -> b) -> a -> b
$ NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Proxy ctyp -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes Proxy ctyp
pctyp
      where
        pctyp :: Proxy ctyp
pctyp = Proxy ctyp
forall k (t :: k). Proxy t
Proxy :: Proxy ctyp

instance {-# OVERLAPPING #-}
         ( AllMime (ctyp ': ctyp' ': ctyps)
         ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where
    allMimeRender :: Proxy (ctyp : ctyp' : ctyps)
-> NoContent -> [(MediaType, ByteString)]
allMimeRender Proxy (ctyp : ctyp' : ctyps)
p NoContent
_ = [MediaType] -> [ByteString] -> [(MediaType, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Proxy (ctyp : ctyp' : ctyps) -> [MediaType]
forall (list :: [*]). AllMime list => Proxy list -> [MediaType]
allMime Proxy (ctyp : ctyp' : ctyps)
p) (ByteString -> [ByteString]
forall a. a -> [a]
repeat ByteString
"")

--------------------------------------------------------------------------
-- Check that all elements of list are instances of MimeUnrender
--------------------------------------------------------------------------
class (AllMime list) => AllMimeUnrender (list :: [*]) a where
    allMimeUnrender :: Proxy list
                    -> [(M.MediaType, ByteString -> Either String a)]

instance AllMimeUnrender '[] a where
    allMimeUnrender :: Proxy '[] -> [(MediaType, ByteString -> Either String a)]
allMimeUnrender Proxy '[]
_ = []

instance ( MimeUnrender ctyp a
         , AllMimeUnrender ctyps a
         ) => AllMimeUnrender (ctyp ': ctyps) a where
    allMimeUnrender :: Proxy (ctyp : ctyps)
-> [(MediaType, ByteString -> Either String a)]
allMimeUnrender Proxy (ctyp : ctyps)
_ =
        (MediaType -> (MediaType, ByteString -> Either String a))
-> [MediaType] -> [(MediaType, ByteString -> Either String a)]
forall a b. (a -> b) -> [a] -> [b]
map MediaType -> (MediaType, ByteString -> Either String a)
mk (NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Proxy ctyp -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes Proxy ctyp
pctyp)
        [(MediaType, ByteString -> Either String a)]
-> [(MediaType, ByteString -> Either String a)]
-> [(MediaType, ByteString -> Either String a)]
forall a. [a] -> [a] -> [a]
++ Proxy ctyps -> [(MediaType, ByteString -> Either String a)]
forall (list :: [*]) a.
AllMimeUnrender list a =>
Proxy list -> [(MediaType, ByteString -> Either String a)]
allMimeUnrender Proxy ctyps
pctyps
      where
        mk :: MediaType -> (MediaType, ByteString -> Either String a)
mk MediaType
ct   = (MediaType
ct, Proxy ctyp -> MediaType -> ByteString -> Either String a
forall k (ctype :: k) a.
MimeUnrender ctype a =>
Proxy ctype -> MediaType -> ByteString -> Either String a
mimeUnrenderWithType Proxy ctyp
pctyp MediaType
ct)
        pctyp :: Proxy ctyp
pctyp  = Proxy ctyp
forall k (t :: k). Proxy t
Proxy :: Proxy ctyp
        pctyps :: Proxy ctyps
pctyps = Proxy ctyps
forall k (t :: k). Proxy t
Proxy :: Proxy ctyps

--------------------------------------------------------------------------
-- * MimeRender Instances

-- | `encode`
instance {-# OVERLAPPABLE #-}
         ToJSON a => MimeRender JSON a where
    mimeRender :: Proxy JSON -> a -> ByteString
mimeRender Proxy JSON
_ = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- | @urlEncodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance {-# OVERLAPPABLE #-}
         ToForm a => MimeRender FormUrlEncoded a where
    mimeRender :: Proxy FormUrlEncoded -> a -> ByteString
mimeRender Proxy FormUrlEncoded
_ = a -> ByteString
forall a. ToForm a => a -> ByteString
urlEncodeAsForm

-- | `TextL.encodeUtf8`
instance MimeRender PlainText TextL.Text where
    mimeRender :: Proxy PlainText -> Text -> ByteString
mimeRender Proxy PlainText
_ = Text -> ByteString
TextL.encodeUtf8

-- | @fromStrict . TextS.encodeUtf8@
instance MimeRender PlainText TextS.Text where
    mimeRender :: Proxy PlainText -> Text -> ByteString
mimeRender Proxy PlainText
_ = ByteString -> ByteString
fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TextS.encodeUtf8

-- | @BC.pack@
instance MimeRender PlainText String where
    mimeRender :: Proxy PlainText -> String -> ByteString
mimeRender Proxy PlainText
_ = String -> ByteString
BC.pack

-- | @id@
instance MimeRender OctetStream ByteString where
    mimeRender :: Proxy OctetStream -> ByteString -> ByteString
mimeRender Proxy OctetStream
_ = ByteString -> ByteString
forall a. a -> a
id

-- | `fromStrict`
instance MimeRender OctetStream BS.ByteString where
    mimeRender :: Proxy OctetStream -> ByteString -> ByteString
mimeRender Proxy OctetStream
_ = ByteString -> ByteString
fromStrict

-- | A type for responses without content-body.
data NoContent = NoContent
  deriving (Int -> NoContent -> ShowS
[NoContent] -> ShowS
NoContent -> String
(Int -> NoContent -> ShowS)
-> (NoContent -> String)
-> ([NoContent] -> ShowS)
-> Show NoContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoContent] -> ShowS
$cshowList :: [NoContent] -> ShowS
show :: NoContent -> String
$cshow :: NoContent -> String
showsPrec :: Int -> NoContent -> ShowS
$cshowsPrec :: Int -> NoContent -> ShowS
Show, NoContent -> NoContent -> Bool
(NoContent -> NoContent -> Bool)
-> (NoContent -> NoContent -> Bool) -> Eq NoContent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoContent -> NoContent -> Bool
$c/= :: NoContent -> NoContent -> Bool
== :: NoContent -> NoContent -> Bool
$c== :: NoContent -> NoContent -> Bool
Eq, ReadPrec [NoContent]
ReadPrec NoContent
Int -> ReadS NoContent
ReadS [NoContent]
(Int -> ReadS NoContent)
-> ReadS [NoContent]
-> ReadPrec NoContent
-> ReadPrec [NoContent]
-> Read NoContent
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NoContent]
$creadListPrec :: ReadPrec [NoContent]
readPrec :: ReadPrec NoContent
$creadPrec :: ReadPrec NoContent
readList :: ReadS [NoContent]
$creadList :: ReadS [NoContent]
readsPrec :: Int -> ReadS NoContent
$creadsPrec :: Int -> ReadS NoContent
Read, (forall x. NoContent -> Rep NoContent x)
-> (forall x. Rep NoContent x -> NoContent) -> Generic NoContent
forall x. Rep NoContent x -> NoContent
forall x. NoContent -> Rep NoContent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NoContent x -> NoContent
$cfrom :: forall x. NoContent -> Rep NoContent x
Generic)

instance NFData NoContent


--------------------------------------------------------------------------
-- * MimeUnrender Instances

-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
-- objects and arrays.
--
-- Will handle trailing whitespace, but not trailing junk. ie.
--
-- >>> eitherDecodeLenient "1 " :: Either String Int
-- Right 1
--
-- >>> eitherDecodeLenient "1 junk" :: Either String Int
-- Left "trailing junk after valid JSON: endOfInput"
eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
eitherDecodeLenient :: ByteString -> Either String a
eitherDecodeLenient ByteString
input =
    Parser Value -> ByteString -> Either String Value
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Value
parser (ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
input) Either String Value
-> (Value -> Either String a) -> Either String a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON
  where
    parser :: Parser Value
parser = Parser ()
skipSpace
          Parser () -> Parser Value -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Value
Data.Aeson.Parser.value
          Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
          Parser Value -> Parser () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser ()
forall t. Chunk t => Parser t ()
endOfInput Parser () -> String -> Parser ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"trailing junk after valid JSON")

-- | `eitherDecode`
instance FromJSON a => MimeUnrender JSON a where
    mimeUnrender :: Proxy JSON -> ByteString -> Either String a
mimeUnrender Proxy JSON
_ = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeLenient

-- | @urlDecodeAsForm@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromForm a => MimeUnrender FormUrlEncoded a where
    mimeUnrender :: Proxy FormUrlEncoded -> ByteString -> Either String a
mimeUnrender Proxy FormUrlEncoded
_ = (Text -> String) -> Either Text a -> Either String a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Text -> String
TextS.unpack (Either Text a -> Either String a)
-> (ByteString -> Either Text a) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text a
forall a. FromForm a => ByteString -> Either Text a
urlDecodeAsForm

-- | @left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TextL.Text where
    mimeUnrender :: Proxy PlainText -> ByteString -> Either String Text
mimeUnrender Proxy PlainText
_ = (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
TextL.decodeUtf8'

-- | @left show . TextS.decodeUtf8' . toStrict@
instance MimeUnrender PlainText TextS.Text where
    mimeUnrender :: Proxy PlainText -> ByteString -> Either String Text
mimeUnrender Proxy PlainText
_ = (UnicodeException -> String)
-> Either UnicodeException Text -> Either String Text
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left UnicodeException -> String
forall a. Show a => a -> String
show (Either UnicodeException Text -> Either String Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
TextS.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (ByteString -> ByteString)
-> ByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict

-- | @Right . BC.unpack@
instance MimeUnrender PlainText String where
    mimeUnrender :: Proxy PlainText -> ByteString -> Either String String
mimeUnrender Proxy PlainText
_ = String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> (ByteString -> String) -> ByteString -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack

-- | @Right . id@
instance MimeUnrender OctetStream ByteString where
    mimeUnrender :: Proxy OctetStream -> ByteString -> Either String ByteString
mimeUnrender Proxy OctetStream
_ = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall a. a -> a
id

-- | @Right . toStrict@
instance MimeUnrender OctetStream BS.ByteString where
    mimeUnrender :: Proxy OctetStream -> ByteString -> Either String ByteString
mimeUnrender Proxy OctetStream
_ = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict


-- $setup
-- >>> :set -XFlexibleInstances
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XOverloadedStrings
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }