Compare commits

...

4 Commits

Author SHA1 Message Date
Julian K. Arni
9d9091f8e9 Update IO content-type unrendering.
We no longer need to use unsafeInterleaveIO.
2016-08-17 14:36:24 -03:00
Nickolay Kudasov
10da6fd454 Update servant-server 2016-08-17 14:05:29 -03:00
Nickolay Kudasov
372a6c7753 Update servant-client 2016-08-17 14:03:24 -03:00
Nickolay Kudasov
734e8a00d4 Allow IO when unrendering content types 2016-08-17 14:03:24 -03:00
6 changed files with 107 additions and 55 deletions

View File

@ -186,7 +186,8 @@ performRequestCT ct reqMethod req manager reqHost = do
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of unrenderResult <- liftIO . runExceptT $ mimeUnrender ct respBody
case unrenderResult of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)

View File

@ -22,6 +22,7 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ServantErr , module Servant.Server.Internal.ServantErr
) where ) where
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Char8 as BC8
@ -443,12 +444,15 @@ instance ( AllCTUnrender list a, HasServer api context
-- http://www.w3.org/2001/tag/2002/0129-mime -- http://www.w3.org/2001/tag/2002/0129-mime
let contentTypeH = fromMaybe "application/octet-stream" let contentTypeH = fromMaybe "application/octet-stream"
$ lookup hContentType $ requestHeaders request $ lookup hContentType $ requestHeaders request
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) lbody <- liftIO $ lazyRequestBody request
<$> liftIO (lazyRequestBody request) let mrqbody = handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) lbody
case mrqbody of case mrqbody of
Nothing -> delayedFailFatal err415 Nothing -> delayedFailFatal err415
Just (Left e) -> delayedFailFatal err400 { errBody = cs e } Just run -> do
Just (Right v) -> return v val <- liftIO $ runExceptT run
case val of
Left e -> delayedFailFatal err400 { errBody = cs e }
Right v -> return v
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @api@. -- pass the rest of the request path to @api@.

View File

@ -266,7 +266,7 @@ errorChoiceSpec = describe "Multiple handlers return errors"
-- * Instances {{{ -- * Instances {{{
instance MimeUnrender PlainText Int where instance MimeUnrender PlainText Int where
mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x) mimeUnrender _ x = maybe (throwE "no parse") return (readMay $ BCL.unpack x)
instance MimeRender PlainText Int where instance MimeRender PlainText Int where
mimeRender _ = BCL.pack . show mimeRender _ = BCL.pack . show

View File

@ -109,6 +109,7 @@ test-suite spec
, attoparsec , attoparsec
, bytestring , bytestring
, hspec == 2.* , hspec == 2.*
, mtl >= 2 && < 3
, QuickCheck , QuickCheck
, quickcheck-instances , quickcheck-instances
, servant , servant

View File

@ -74,6 +74,7 @@ module Servant.API.ContentTypes
import Control.Arrow (left) import Control.Arrow (left)
import Control.Monad.Compat import Control.Monad.Compat
import Control.Monad.Except (ExceptT, MonadError(..))
import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson (FromJSON(..), ToJSON(..), encode)
import Data.Aeson.Parser (value) import Data.Aeson.Parser (value)
import Data.Aeson.Types (parseEither) import Data.Aeson.Types (parseEither)
@ -183,6 +184,7 @@ instance OVERLAPPABLE_
-- --
-- >>> import Network.HTTP.Media hiding (Accept) -- >>> import Network.HTTP.Media hiding (Accept)
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSC -- >>> import qualified Data.ByteString.Lazy.Char8 as BSC
-- >>> import Control.Monad.Except
-- >>> data MyContentType = MyContentType String -- >>> data MyContentType = MyContentType String
-- --
-- >>> :{ -- >>> :{
@ -194,19 +196,19 @@ instance OVERLAPPABLE_
--instance Read a => MimeUnrender MyContentType a where --instance Read a => MimeUnrender MyContentType a where
-- mimeUnrender _ bs = case BSC.take 12 bs of -- mimeUnrender _ bs = case BSC.take 12 bs of
-- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs -- "MyContentType" -> return . read . BSC.unpack $ BSC.drop 12 bs
-- _ -> Left "didn't start with the magic incantation" -- _ -> throwError "didn't start with the magic incantation"
-- :} -- :}
-- --
-- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int -- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int
-- --
class Accept ctype => MimeUnrender ctype a where class Accept ctype => MimeUnrender ctype a where
mimeUnrender :: Proxy ctype -> ByteString -> Either String a mimeUnrender :: Proxy ctype -> ByteString -> ExceptT String IO a
class AllCTUnrender (list :: [*]) a where class AllCTUnrender (list :: [*]) a where
handleCTypeH :: Proxy list handleCTypeH :: Proxy list
-> ByteString -- Content-Type header -> ByteString -- Content-Type header
-> ByteString -- Request body -> ByteString -- Request body
-> Maybe (Either String a) -> Maybe (ExceptT String IO a)
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
@ -269,7 +271,7 @@ instance OVERLAPPING_
class (AllMime list) => AllMimeUnrender (list :: [*]) a where class (AllMime list) => AllMimeUnrender (list :: [*]) a where
allMimeUnrender :: Proxy list allMimeUnrender :: Proxy list
-> ByteString -> ByteString
-> [(M.MediaType, Either String a)] -> [(M.MediaType, ExceptT String IO a)]
instance AllMimeUnrender '[] a where instance AllMimeUnrender '[] a where
allMimeUnrender _ _ = [] allMimeUnrender _ _ = []
@ -344,35 +346,35 @@ eitherDecodeLenient input =
<* skipSpace <* skipSpace
<* (endOfInput <?> "trailing junk after valid JSON") <* (endOfInput <?> "trailing junk after valid JSON")
-- | `eitherDecode` -- | @either throwError return . eitherDecodeLenient@
instance FromJSON a => MimeUnrender JSON a where instance FromJSON a => MimeUnrender JSON a where
mimeUnrender _ = eitherDecodeLenient mimeUnrender _ = either throwError return . eitherDecodeLenient
-- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ -- | @either throwError return . (decodeFormUrlEncoded >=> fromFormUrlEncoded)@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@) -- holds if every element of x is non-null (i.e., not @("", "")@)
instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
mimeUnrender _ = decodeFormUrlEncoded >=> fromFormUrlEncoded mimeUnrender _ = either throwError return . (decodeFormUrlEncoded >=> fromFormUrlEncoded)
-- | @left show . TextL.decodeUtf8'@ -- | @either throwError return . left show . TextL.decodeUtf8'@
instance MimeUnrender PlainText TextL.Text where instance MimeUnrender PlainText TextL.Text where
mimeUnrender _ = left show . TextL.decodeUtf8' mimeUnrender _ = either throwError return . left show . TextL.decodeUtf8'
-- | @left show . TextS.decodeUtf8' . toStrict@ -- | @either throwError return . left show . TextS.decodeUtf8' . toStrict@
instance MimeUnrender PlainText TextS.Text where instance MimeUnrender PlainText TextS.Text where
mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict mimeUnrender _ = either throwError return . left show . TextS.decodeUtf8' . toStrict
-- | @Right . BC.unpack@ -- | @return . BC.unpack@
instance MimeUnrender PlainText String where instance MimeUnrender PlainText String where
mimeUnrender _ = Right . BC.unpack mimeUnrender _ = return . BC.unpack
-- | @Right . id@ -- | @return . id@
instance MimeUnrender OctetStream ByteString where instance MimeUnrender OctetStream ByteString where
mimeUnrender _ = Right . id mimeUnrender _ = return
-- | @Right . toStrict@ -- | @return . toStrict@
instance MimeUnrender OctetStream BS.ByteString where instance MimeUnrender OctetStream BS.ByteString where
mimeUnrender _ = Right . toStrict mimeUnrender _ = return . toStrict
-------------------------------------------------------------------------- --------------------------------------------------------------------------

View File

@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.API.ContentTypesSpec where module Servant.API.ContentTypesSpec where
@ -12,6 +13,9 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Arrow import Control.Arrow
import Control.Monad (when)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans (liftIO)
import Data.Aeson import Data.Aeson
import Data.ByteString.Char8 (ByteString, append, pack) import Data.ByteString.Char8 (ByteString, append, pack)
import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as BSL
@ -28,10 +32,40 @@ import GHC.Generics
import Network.URL (exportParams, importParams) import Network.URL (exportParams, importParams)
import Test.Hspec import Test.Hspec
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Monadic
import "quickcheck-instances" Test.QuickCheck.Instances () import "quickcheck-instances" Test.QuickCheck.Instances ()
import Servant.API.ContentTypes import Servant.API.ContentTypes
shouldUnrenderTo :: (MimeUnrender ct a, Eq a, Show a) => (Proxy ct, BSL.ByteString) -> a -> IO ()
shouldUnrenderTo (p, bs) x = do
res <- runExceptT (mimeUnrender p bs)
res `shouldBe` Right x
shouldNotUnrenderTo :: forall ct a. (MimeUnrender ct a, Show a) =>
(Proxy ct, BSL.ByteString) -> Proxy a -> IO ()
shouldNotUnrenderTo (p, bs) _ = do
res <- runExceptT (mimeUnrender p bs)
res `shouldSatisfy` (isLeft :: Either e a -> Bool)
shouldHandleCTypeH :: (AllCTUnrender cts a, Eq a, Show a) =>
(Proxy cts, BSL.ByteString, BSL.ByteString) -> a -> IO ()
shouldHandleCTypeH (p, ct, bs) x = do
res <- traverse runExceptT (handleCTypeH p ct bs)
res `shouldBe` Just (Right x)
shouldNotFindCTypeH :: forall cts a. (AllCTUnrender cts a, Eq a, Show a) =>
(Proxy cts, BSL.ByteString, BSL.ByteString) -> Proxy a -> IO ()
shouldNotFindCTypeH (p, ct, bs) _ = do
res <- traverse runExceptT (handleCTypeH p ct bs)
res `shouldBe` (Nothing :: Maybe (Either String a))
shouldHandleCTypeHSatisfy :: forall cts a. (AllCTUnrender cts a, Show a) =>
(Proxy cts, BSL.ByteString, BSL.ByteString) -> (Maybe (Either String a) -> Bool) -> IO ()
shouldHandleCTypeHSatisfy (p, ct, bs) f = do
res <- traverse runExceptT (handleCTypeH p ct bs)
res `shouldSatisfy` f
spec :: Spec spec :: Spec
spec = describe "Servant.API.ContentTypes" $ do spec = describe "Servant.API.ContentTypes" $ do
@ -53,31 +87,37 @@ spec = describe "Servant.API.ContentTypes" $ do
let p = Proxy :: Proxy JSON let p = Proxy :: Proxy JSON
it "handles whitespace at end of input" $ do it "handles whitespace at end of input" $ do
mimeUnrender p "[1] " `shouldBe` Right [1 :: Int] (p, "[1] ") `shouldUnrenderTo` [1 :: Int]
it "handles whitespace at beginning of input" $ do it "handles whitespace at beginning of input" $ do
mimeUnrender p " [1] " `shouldBe` Right [1 :: Int] (p, " [1]") `shouldUnrenderTo` [1 :: Int]
it "does not like junk at end of input" $ do it "does not like junk at end of input" $ do
mimeUnrender p "[1] this probably shouldn't work" (p, "[1] this probably shouldn't work")
`shouldSatisfy` (isLeft :: Either a [Int] -> Bool) `shouldNotUnrenderTo` (Proxy :: Proxy [Int])
it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int]) property $ \x -> monadicIO $ do
res <- liftIO $ runExceptT (mimeUnrender p (mimeRender p x))
assert (res == Right (x::[Int]))
it "has mimeUnrender reverse mimeRender for valid top-level json " $ do it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData) property $ \x -> monadicIO $ do
res <- liftIO $ runExceptT (mimeUnrender p (mimeRender p x))
assert (res == Right (x::[SomeData]))
describe "The FormUrlEncoded Content-Type type" $ do describe "The FormUrlEncoded Content-Type type" $ do
let p = Proxy :: Proxy FormUrlEncoded let p = Proxy :: Proxy FormUrlEncoded
it "has mimeUnrender reverse mimeRender" $ do it "has mimeUnrender reverse mimeRender" $ do
property $ \x -> mempty `notElem` x property $ \x -> monadicIO $ when (mempty `notElem` x) $ do
==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)]) res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x)
assert (res == Right (x::[(TextS.Text,TextS.Text)]))
it "has mimeUnrender reverse exportParams (Network.URL)" $ do it "has mimeUnrender reverse exportParams (Network.URL)" $ do
property $ \x -> mempty `notElem` x property $ \x -> monadicIO $ when (mempty `notElem` x) $ do
==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) res <- liftIO . runExceptT $ mimeUnrender p . cs . exportParams . map (cs *** cs) $ x
assert (res == Right (x::[(TextS.Text,TextS.Text)]))
it "has importParams (Network.URL) reverse mimeRender" $ do it "has importParams (Network.URL) reverse mimeRender" $ do
property $ \x -> mempty `notElem` x property $ \x -> mempty `notElem` x
@ -87,21 +127,29 @@ spec = describe "Servant.API.ContentTypes" $ do
let p = Proxy :: Proxy PlainText let p = Proxy :: Proxy PlainText
it "has mimeUnrender reverse mimeRender (lazy Text)" $ do it "has mimeUnrender reverse mimeRender (lazy Text)" $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text) property $ \x -> monadicIO $ do
res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x)
assert (res == Right (x::TextL.Text))
it "has mimeUnrender reverse mimeRender (strict Text)" $ do it "has mimeUnrender reverse mimeRender (strict Text)" $ do
property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text) property $ \x -> monadicIO $ do
res <- liftIO . runExceptT $ mimeUnrender p (mimeRender p x)
assert (res == Right (x::TextS.Text))
describe "The OctetStream Content-Type type" $ do describe "The OctetStream Content-Type type" $ do
let p = Proxy :: Proxy OctetStream let p = Proxy :: Proxy OctetStream
it "is id (Lazy ByteString)" $ do it "is id (Lazy ByteString)" $ do
property $ \x -> mimeRender p x == (x :: BSL.ByteString) property $ \x -> monadicIO $ do
&& mimeUnrender p x == Right x assert (mimeRender p x == (x :: BSL.ByteString))
res <- liftIO . runExceptT $ mimeUnrender p x
assert (res == Right x)
it "is fromStrict/toStrict (Strict ByteString)" $ do it "is fromStrict/toStrict (Strict ByteString)" $ do
property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString) property $ \x -> monadicIO $ do
&& mimeUnrender p (BSL.fromStrict x) == Right x assert (mimeRender p x == BSL.fromStrict (x :: ByteString))
res <- liftIO . runExceptT $ mimeUnrender p (BSL.fromStrict x)
assert (res == Right x)
describe "handleAcceptH" $ do describe "handleAcceptH" $ do
@ -147,33 +195,29 @@ spec = describe "Servant.API.ContentTypes" $ do
describe "handleCTypeH" $ do describe "handleCTypeH" $ do
it "returns Nothing if the 'Content-Type' header doesn't match" $ do it "returns Nothing if the 'Content-Type' header doesn't match" $ do
handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " (Proxy :: Proxy '[JSON], "text/plain", "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 ")
`shouldBe` (Nothing :: Maybe (Either String Value)) `shouldNotFindCTypeH` (Proxy :: Proxy Value)
context "the 'Content-Type' header matches" $ do context "the 'Content-Type' header matches" $ do
it "returns Just if the parameter matches" $ do it "returns Just if the parameter matches" $ do
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ")
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
it "returns Just if there is no parameter" $ do it "returns Just if there is no parameter" $ do
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" (Proxy :: Proxy '[JSON], "application/json", "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 ")
"𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldHandleCTypeHSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
`shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool)
it "returns Just Left if the decoding fails" $ do it "returns Just Left if the decoding fails" $ do
let isJustLeft :: Maybe (Either String Value) -> Bool let isJustLeft :: Maybe (Either String Value) -> Bool
isJustLeft (Just (Left _)) = True isJustLeft (Just (Left _)) = True
isJustLeft _ = False isJustLeft _ = False
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" (Proxy :: Proxy '[JSON], "application/json", "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- ")
"𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- " `shouldHandleCTypeHSatisfy` isJustLeft
`shouldSatisfy` isJustLeft
it "returns Just (Right val) if the decoding succeeds" $ do it "returns Just (Right val) if the decoding succeeds" $ do
let val = SomeData "Of cabbages--and kings" 12 let val = SomeData "Of cabbages--and kings" 12
handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" (Proxy :: Proxy '[JSON], "application/json", encode val)
(encode val) `shouldHandleCTypeH` val
`shouldBe` Just (Right val)
#if MIN_VERSION_aeson(0,9,0) #if MIN_VERSION_aeson(0,9,0)
-- aeson >= 0.9 decodes top-level strings -- aeson >= 0.9 decodes top-level strings