Preliminary work to support headers in responses
This commit is contained in:
Timo von Holtz
parent
24e32f194e
commit
642910b3b3
2 changed files with 46 additions and 41 deletions
|
|
@ -6,6 +6,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
|
@ -83,6 +84,7 @@ import qualified Data.Text.Lazy.Encoding as TextL
|
|||
import Data.Typeable
|
||||
import GHC.Exts (Constraint)
|
||||
import qualified Network.HTTP.Media as M
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.URI (escapeURIString, isUnreserved,
|
||||
unEscapeString)
|
||||
|
||||
|
|
@ -147,13 +149,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
|
|||
-- > type MyAPI = "path" :> Get '[MyContentType] Int
|
||||
--
|
||||
class Accept ctype => MimeRender ctype a where
|
||||
toByteString :: Proxy ctype -> a -> ByteString
|
||||
toByteString :: Proxy ctype -> a -> (ResponseHeaders, ByteString)
|
||||
|
||||
class 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)
|
||||
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, (ResponseHeaders, ByteString))
|
||||
|
||||
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTRender ctyps a where
|
||||
|
|
@ -188,18 +190,19 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
|
|||
-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int
|
||||
--
|
||||
class Accept ctype => MimeUnrender ctype a where
|
||||
fromByteString :: Proxy ctype -> ByteString -> Either String a
|
||||
fromByteString :: Proxy ctype -> ResponseHeaders -> ByteString -> Either String a
|
||||
|
||||
class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
|
||||
handleCTypeH :: Proxy list
|
||||
-> ResponseHeaders -- Headers
|
||||
-> ByteString -- Content-Type header
|
||||
-> ByteString -- Request body
|
||||
-> Maybe (Either String a)
|
||||
|
||||
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTUnrender ctyps a where
|
||||
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
|
||||
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
|
||||
handleCTypeH _ hs ctypeH body = M.mapContentMedia lkup (cs ctypeH)
|
||||
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) hs body
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * Utils (Internal)
|
||||
|
|
@ -211,7 +214,7 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
|||
class AllMimeRender (list :: [*]) a where
|
||||
allMimeRender :: Proxy list
|
||||
-> a -- value to serialize
|
||||
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||
-> [(M.MediaType, (ResponseHeaders, ByteString))] -- content-types/response pairs
|
||||
|
||||
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
|
||||
|
|
@ -234,17 +237,18 @@ instance AllMimeRender '[] a where
|
|||
--------------------------------------------------------------------------
|
||||
class AllMimeUnrender (list :: [*]) a where
|
||||
allMimeUnrender :: Proxy list
|
||||
-> ResponseHeaders
|
||||
-> ByteString
|
||||
-> [(M.MediaType, Either String a)]
|
||||
|
||||
instance AllMimeUnrender '[] a where
|
||||
allMimeUnrender _ _ = []
|
||||
allMimeUnrender _ _ _ = []
|
||||
|
||||
instance ( MimeUnrender ctyp a
|
||||
, AllMimeUnrender ctyps a
|
||||
) => AllMimeUnrender (ctyp ': ctyps) a where
|
||||
allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
|
||||
:(allMimeUnrender pctyps val)
|
||||
allMimeUnrender _ hs val = (contentType pctyp, fromByteString pctyp hs val)
|
||||
:(allMimeUnrender pctyps hs val)
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy ctyps
|
||||
|
||||
|
|
@ -257,29 +261,29 @@ type family IsNonEmpty (list :: [*]) :: Constraint where
|
|||
|
||||
-- | `encode`
|
||||
instance ToJSON a => MimeRender JSON a where
|
||||
toByteString _ = encode
|
||||
toByteString _ = ([],) . encode
|
||||
|
||||
-- | @encodeFormUrlEncoded . toFormUrlEncoded@
|
||||
-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
|
||||
-- holds if every element of x is non-null (i.e., not @("", "")@)
|
||||
instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
|
||||
toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
|
||||
toByteString _ = ([],) . encodeFormUrlEncoded . toFormUrlEncoded
|
||||
|
||||
-- | `TextL.encodeUtf8`
|
||||
instance MimeRender PlainText TextL.Text where
|
||||
toByteString _ = TextL.encodeUtf8
|
||||
toByteString _ = ([],) . TextL.encodeUtf8
|
||||
|
||||
-- | @fromStrict . TextS.encodeUtf8@
|
||||
instance MimeRender PlainText TextS.Text where
|
||||
toByteString _ = fromStrict . TextS.encodeUtf8
|
||||
toByteString _ = ([],) . fromStrict . TextS.encodeUtf8
|
||||
|
||||
-- | @id@
|
||||
instance MimeRender OctetStream ByteString where
|
||||
toByteString _ = id
|
||||
toByteString _ = ([],)
|
||||
|
||||
-- | `fromStrict`
|
||||
instance MimeRender OctetStream BS.ByteString where
|
||||
toByteString _ = fromStrict
|
||||
toByteString _ = ([],) . fromStrict
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
|
@ -294,29 +298,29 @@ eitherDecodeLenient input = do
|
|||
|
||||
-- | `eitherDecode`
|
||||
instance FromJSON a => MimeUnrender JSON a where
|
||||
fromByteString _ = eitherDecodeLenient
|
||||
fromByteString _ _ = eitherDecodeLenient
|
||||
|
||||
-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@
|
||||
-- Note that the @fromByteString p (toByteString p x) == Right x@ law only
|
||||
-- holds if every element of x is non-null (i.e., not @("", "")@)
|
||||
instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
|
||||
fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
|
||||
fromByteString _ _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
|
||||
|
||||
-- | @left show . TextL.decodeUtf8'@
|
||||
instance MimeUnrender PlainText TextL.Text where
|
||||
fromByteString _ = left show . TextL.decodeUtf8'
|
||||
fromByteString _ _ = left show . TextL.decodeUtf8'
|
||||
|
||||
-- | @left show . TextS.decodeUtf8' . toStrict@
|
||||
instance MimeUnrender PlainText TextS.Text where
|
||||
fromByteString _ = left show . TextS.decodeUtf8' . toStrict
|
||||
fromByteString _ _ = left show . TextS.decodeUtf8' . toStrict
|
||||
|
||||
-- | @Right . id@
|
||||
instance MimeUnrender OctetStream ByteString where
|
||||
fromByteString _ = Right . id
|
||||
fromByteString _ _ = Right
|
||||
|
||||
-- | @Right . toStrict@
|
||||
instance MimeUnrender OctetStream BS.ByteString where
|
||||
fromByteString _ = Right . toStrict
|
||||
fromByteString _ _ = Right . toStrict
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.API.ContentTypesSpec where
|
||||
|
||||
|
|
@ -36,11 +37,11 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
|
||||
it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do
|
||||
let p = Proxy :: Proxy JSON
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int])
|
||||
property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::[Int])
|
||||
|
||||
it "has fromByteString reverse toByteString for valid top-level json " $ do
|
||||
let p = Proxy :: Proxy JSON
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData)
|
||||
property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::SomeData)
|
||||
|
||||
describe "The FormUrlEncoded Content-Type type" $ do
|
||||
|
||||
|
|
@ -50,39 +51,39 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
it "has fromByteString reverse toByteString" $ do
|
||||
let p = Proxy :: Proxy FormUrlEncoded
|
||||
property $ \x -> all isNonNull x
|
||||
==> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
|
||||
==> uncurry (fromByteString p) (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
|
||||
|
||||
it "has fromByteString reverse exportParams (Network.URL)" $ do
|
||||
let p = Proxy :: Proxy FormUrlEncoded
|
||||
property $ \x -> all isNonNull x
|
||||
==> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
|
||||
==> (fromByteString p [] . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
|
||||
|
||||
it "has importParams (Network.URL) reverse toByteString" $ do
|
||||
let p = Proxy :: Proxy FormUrlEncoded
|
||||
property $ \x -> all isNonNull x
|
||||
==> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
|
||||
==> (fmap (map (cs *** cs)) . importParams . cs . snd . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
|
||||
|
||||
describe "The PlainText Content-Type type" $ do
|
||||
|
||||
it "has fromByteString reverse toByteString (lazy Text)" $ do
|
||||
let p = Proxy :: Proxy PlainText
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text)
|
||||
property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::TextL.Text)
|
||||
|
||||
it "has fromByteString reverse toByteString (strict Text)" $ do
|
||||
let p = Proxy :: Proxy PlainText
|
||||
property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text)
|
||||
property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::TextS.Text)
|
||||
|
||||
describe "The OctetStream Content-Type type" $ do
|
||||
|
||||
it "is id (Lazy ByteString)" $ do
|
||||
let p = Proxy :: Proxy OctetStream
|
||||
property $ \x -> toByteString p x == (x :: BSL.ByteString)
|
||||
&& fromByteString p x == Right x
|
||||
property $ \x -> toByteString p x == ([], x :: BSL.ByteString)
|
||||
&& fromByteString p [] x == Right x
|
||||
|
||||
it "is fromStrict/toStrict (Strict ByteString)" $ do
|
||||
let p = Proxy :: Proxy OctetStream
|
||||
property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString)
|
||||
&& fromByteString p (BSL.fromStrict x) == Right x
|
||||
property $ \x -> toByteString p x == ([], BSL.fromStrict x)
|
||||
&& fromByteString p [] (BSL.fromStrict x) == Right x
|
||||
|
||||
describe "handleAcceptH" $ do
|
||||
|
||||
|
|
@ -110,7 +111,7 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
|
||||
it "returns the appropriately serialized representation" $ do
|
||||
property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData)
|
||||
== Just ("application/json", encode x)
|
||||
== Just ("application/json", ([], encode x))
|
||||
|
||||
it "respects the Accept spec ordering" $ do
|
||||
let highest a b c = maximumBy (compare `on` snd)
|
||||
|
|
@ -128,17 +129,17 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
describe "handleCTypeH" $ do
|
||||
|
||||
it "returns Nothing if the 'Content-Type' header doesn't match" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 "
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) [] "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 "
|
||||
`shouldBe` (Nothing :: Maybe (Either String Value))
|
||||
|
||||
context "the 'Content-Type' header matches" $ do
|
||||
it "returns Just if the parameter matches" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json"
|
||||
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
|
||||
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
|
||||
|
||||
it "returns Just if there is no parameter" $ do
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json"
|
||||
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 "
|
||||
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
|
||||
|
||||
|
|
@ -146,13 +147,13 @@ spec = describe "Servant.API.ContentTypes" $ do
|
|||
let isJustLeft :: Maybe (Either String Value) -> Bool
|
||||
isJustLeft (Just (Left _)) = True
|
||||
isJustLeft _ = False
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json"
|
||||
"𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- "
|
||||
`shouldSatisfy` isJustLeft
|
||||
|
||||
it "returns Just (Right val) if the decoding succeeds" $ do
|
||||
let val = SomeData "Of cabbages--and kings" 12
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json"
|
||||
handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json"
|
||||
(encode val)
|
||||
`shouldBe` Just (Right val)
|
||||
|
||||
|
|
@ -182,13 +183,13 @@ instance Arbitrary ZeroToOne where
|
|||
arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
|
||||
|
||||
instance MimeRender OctetStream Int where
|
||||
toByteString _ = cs . show
|
||||
toByteString _ = ([],) . cs . show
|
||||
|
||||
instance MimeRender PlainText Int where
|
||||
toByteString _ = cs . show
|
||||
toByteString _ = ([],) . cs . show
|
||||
|
||||
instance MimeRender PlainText ByteString where
|
||||
toByteString _ = cs
|
||||
toByteString _ = ([],) . cs
|
||||
|
||||
instance ToJSON ByteString where
|
||||
toJSON x = object [ "val" .= x ]
|
||||
|
|
|
|||
Loading…
Reference in a new issue