eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Allow IO when unrendering content types

Browse source
This commit is contained in:
Nickolay Kudasov 2016-01-20 02:40:49 +03:00 committed by Julian K. Arni
parent f5efaf9416
commit 734e8a00d4
3 changed files with 95 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant/servant.cabal
View file

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

38
servant/src/Servant/API/ContentTypes.hs
View file

@ -74,6 +74,7 @@ module Servant.API.ContentTypes
import Control.Arrow (left)
import Control.Monad.Compat
import Control.Monad.Except (ExceptT, MonadError(..))
import Data.Aeson (FromJSON(..), ToJSON(..), encode)
import Data.Aeson.Parser (value)
import Data.Aeson.Types (parseEither)
@ -183,6 +184,7 @@ instance OVERLAPPABLE_
--
-- >>> import Network.HTTP.Media hiding (Accept)
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSC
-- >>> import Control.Monad.Except
-- >>> data MyContentType = MyContentType String
--
-- >>> :{
@ -194,19 +196,19 @@ instance OVERLAPPABLE_
--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"
-- _ -> throwError "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 -> ByteString -> ExceptT String IO a
class AllCTUnrender (list :: [*]) a where
handleCTypeH :: Proxy list
-> ByteString -- Content-Type header
-> ByteString -- Request body
-> Maybe (Either String a)
-> Maybe (ExceptT String IO a)
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
@ -269,7 +271,7 @@ instance OVERLAPPING_
class (AllMime list) => AllMimeUnrender (list :: [*]) a where
allMimeUnrender :: Proxy list
-> ByteString
-> [(M.MediaType, Either String a)]
-> [(M.MediaType, ExceptT String IO a)]
instance AllMimeUnrender '[] a where
allMimeUnrender _ _ = []
@ -344,35 +346,35 @@ eitherDecodeLenient input =
<* skipSpace
<* (endOfInput <?> "trailing junk after valid JSON")
-- | `eitherDecode`
-- | @either throwError return . eitherDecodeLenient@
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
-- holds if every element of x is non-null (i.e., not @("", "")@)
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
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
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
mimeUnrender _ = Right . BC.unpack
mimeUnrender _ = return . BC.unpack
-- | @Right . id@
-- | @return . id@
instance MimeUnrender OctetStream ByteString where
mimeUnrender _ = Right . id
mimeUnrender _ = return
-- | @Right . toStrict@
-- | @return . toStrict@
instance MimeUnrender OctetStream BS.ByteString where
mimeUnrender _ = Right . toStrict
mimeUnrender _ = return . toStrict
--------------------------------------------------------------------------

104
servant/test/Servant/API/ContentTypesSpec.hs
View file

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