From e9f3341b9e4e08116f5fb4396ed2cc3c7130adc7 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 19 Feb 2015 19:18:43 +0100 Subject: [PATCH] Move more Content-type logic back to servant. --- src/Servant/Server.hs | 5 +- src/Servant/Server/ContentTypes.hs | 160 +----------------------- src/Servant/Server/Internal.hs | 56 +++++---- test/Servant/Server/ContentTypesSpec.hs | 3 +- test/Servant/ServerSpec.hs | 13 +- 5 files changed, 46 insertions(+), 191 deletions(-) diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index f7ca559e..2495022e 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -10,16 +10,13 @@ module Servant.Server , -- * Handlers for all standard combinators HasServer(..) - , -- * Building new Content-Types - Accept(..) - , MimeRender(..) ) where import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.ContentTypes (Accept(..), MimeRender(..)) +import Servant.Server.ContentTypes () -- * Implementing Servers diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index b32ae124..8557dc3c 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -11,7 +11,8 @@ module Servant.Server.ContentTypes where import Control.Monad (join) -import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode) +import Control.Arrow (left) +import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import Data.Proxy (Proxy(..)) @@ -23,86 +24,7 @@ import qualified Network.HTTP.Media as M import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText - , OctetStream) - --- * 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: --- --- > instance Accept HTML where --- > contentType _ = "text" // "html" --- -class Accept ctype where - contentType :: Proxy ctype -> M.MediaType - --- | @text/html;charset=utf-8@ -instance Accept HTML where - contentType _ = "text" M.// "html" M./: ("charset", "utf-8") - --- | @application/json;charset=utf-8@ -instance Accept JSON where - contentType _ = "application" M.// "json" M./: ("charset", "utf-8") - --- | @application/xml;charset=utf-8@ -instance Accept XML where - contentType _ = "application" M.// "xml" M./: ("charset", "utf-8") - --- | @application/javascript;charset=utf-8@ -instance Accept JavaScript where - contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8") - --- | @text/css;charset=utf-8@ -instance Accept CSS where - contentType _ = "text" M.// "css" M./: ("charset", "utf-8") - --- | @text/plain;charset=utf-8@ -instance Accept PlainText where - contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") - --- | @application/octet-stream@ -instance Accept OctetStream where - contentType _ = "application" M.// "octet-stream" - -newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) - --- * 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 where --- > toByteString _ val = pack ("This is MINE! " ++ show val) --- > --- > type MyAPI = "path" :> Get '[MyContentType] Int -class Accept ctype => MimeRender ctype a where - toByteString :: Proxy ctype -> a -> 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) - -instance ( AllMimeRender ctyps a, IsNonEmpty ctyps - ) => AllCTRender ctyps a where - handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps - amrs = amr pctyps val - lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs - - + , OctetStream, MimeRender(..), MimeUnrender(..) ) -------------------------------------------------------------------------- @@ -116,86 +38,14 @@ instance ToJSON a => MimeRender JSON a where instance MimeRender PlainText Text.Text where toByteString _ = Text.encodeUtf8 --------------------------------------------------------------------------- --- * Unrender -class Accept ctype => MimeUnrender ctype a where - fromByteString :: Proxy ctype -> ByteString -> Maybe a - -class AllCTUnrender list a where - handleCTypeH :: Proxy list - -> ByteString -- Content-Type header - -> ByteString -- Request body - -> Maybe a - -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH) - where lkup = amu (Proxy :: Proxy ctyps) body - --------------------------------------------------------------------------- --- * Utils (Internal) - - --------------------------------------------------------------------------- --- Check that all elements of list are instances of MimeRender --------------------------------------------------------------------------- -class AllMimeRender ls a where - amr :: Proxy ls - -> a -- value to serialize - -> [(M.MediaType, ByteString)] -- content-types/response pairs - -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where - amr _ a = [(contentType pctyp, toByteString pctyp a)] - where pctyp = Proxy :: Proxy ctyp - -instance ( MimeRender ctyp a - , MimeRender ctyp' a -- at least two elems to avoid overlap - , AllMimeRender ctyps a - ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where - amr _ a = (contentType pctyp, toByteString pctyp a) - :(contentType pctyp', toByteString pctyp' a) - :(amr pctyps a) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' - - -instance AllMimeRender '[] a where - amr _ _ = [] - --------------------------------------------------------------------------- --- Check that all elements of list are instances of MimeUnrender --------------------------------------------------------------------------- -class AllMimeUnrender ls a where - amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)] - -instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where - amu _ val = [(contentType pctyp, fromByteString pctyp val)] - where pctyp = Proxy :: Proxy ctyp - -instance ( MimeUnrender ctyp a - , MimeUnrender ctyp' a - , AllMimeUnrender ctyps a - ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where - amu _ val = (contentType pctyp, fromByteString pctyp val) - :(contentType pctyp', fromByteString pctyp' val) - :(amu pctyps val) - where pctyp = Proxy :: Proxy ctyp - pctyps = Proxy :: Proxy ctyps - pctyp' = Proxy :: Proxy ctyp' - -type family IsNonEmpty (ls::[*]) :: Constraint where - IsNonEmpty '[] = 'False ~ 'True - IsNonEmpty x = () - -------------------------------------------------------------------------- -- * MimeUnrender Instances -- | @decode@ instance FromJSON a => MimeUnrender JSON a where - fromByteString _ = decode + fromByteString _ = eitherDecode -- | @Text.decodeUtf8'@ instance MimeUnrender PlainText Text.Text where - fromByteString _ = either (const Nothing) Just . Text.decodeUtf8' + fromByteString _ = left show . Text.decodeUtf8' diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index fe2ee529..bb661194 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -9,7 +9,7 @@ module Servant.Server.Internal where import Control.Applicative ((<$>)) import Control.Monad.Trans.Either (EitherT, runEitherT) -import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode') +import Data.Aeson (ToJSON) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) @@ -29,10 +29,10 @@ import Network.Wai ( Response, Request, ResponseReceived, Application , lazyRequestBody, requestHeaders, requestMethod, rawQueryString, responseLBS) import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header - , MatrixParams, MatrixParam, MatrixFlag, + , MatrixParams, MatrixParam, MatrixFlag , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) -import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..) - , AllCTUnrender(..) ) +import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..) + , AllCTUnrender(..),) import Servant.Common.Text (FromText, fromText) @@ -72,39 +72,33 @@ toApplication ra request respond = do respond $ responseLBS methodNotAllowed405 [] "method not allowed" routingRespond (Left (InvalidBody err)) = respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err + routingRespond (Left UnsupportedMediaType) = + respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" routingRespond (Left (HttpError status body)) = respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body routingRespond (Right response) = respond response +-- Note that the ordering of the constructors has great significance! It +-- determines the Ord instance and, consequently, the monoid instance. -- * Route mismatch data RouteMismatch = NotFound -- ^ the usual "not found" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | UnsupportedMediaType -- ^ request body has unsupported media type | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. - deriving (Eq, Show) + deriving (Eq, Ord, Show) --- | --- @ --- > mempty = NotFound --- > --- > _ `mappend` HttpError s b = HttpError s b --- > HttpError s b `mappend` _ = HttpError s b --- > NotFound `mappend` x = x --- > WrongMethod `mappend` InvalidBody s = InvalidBody s --- > WrongMethod `mappend` _ = WrongMethod --- > InvalidBody s `mappend` _ = InvalidBody s --- @ instance Monoid RouteMismatch where mempty = NotFound + -- The following isn't great, since it picks @InvalidBody@ based on + -- alphabetical ordering, but any choice would be arbitrary. + -- + -- "As one judge said to the other, 'Be just and if you can't be just, be + -- arbitrary'" -- William Burroughs + mappend = max - _ `mappend` HttpError s b = HttpError s b - HttpError s b `mappend` _ = HttpError s b - NotFound `mappend` x = x - WrongMethod `mappend` InvalidBody s = InvalidBody s - WrongMethod `mappend` _ = WrongMethod - InvalidBody s `mappend` _ = InvalidBody s -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a = @@ -401,15 +395,22 @@ instance ( AllCTRender ctypes a -- If successfully returning a value, we just require that its type has -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 201 along the way. -instance (Typeable a, ToJSON a) => HasServer (Patch a) where - type Server (Patch a) = EitherT (Int, String) IO a +instance ( AllCTRender ctypes a + , Typeable a + , ToJSON a) => HasServer (Patch ctypes a) where + type Server (Patch ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action respond . succeedWith $ case e of Right out -> case cast out of - Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out) + Nothing -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of + Nothing -> responseLBS (mkStatus 406 "") [] "" + Just (contentT, body) -> responseLBS status200 [ ("Content-Type" + , cs contentT)] body Just () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) @@ -695,8 +696,9 @@ instance ( AllCTUnrender list a, HasServer sublayout mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$> lazyRequestBody request case mrqbody of - Left e -> respond . failWith $ InvalidBody e - Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond + Nothing -> respond . failWith $ UnsupportedMediaType + Just (Left e) -> respond . failWith $ InvalidBody e + Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs index 657f8860..a857738b 100644 --- a/test/Servant/Server/ContentTypesSpec.hs +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -24,8 +24,9 @@ import Test.Hspec import Test.QuickCheck import Servant.API +import Servant.API.ContentTypes import Servant.Server -import Servant.Server.ContentTypes +import Servant.Server.ContentTypes () spec :: Spec diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 2d82037e..26eece0f 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -209,10 +209,10 @@ queryParamSpec = do name = "Alice" } -type MatrixParamApi = "a" :> MatrixParam "name" String :> Get Person - :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get Person - :<|> "c" :> MatrixFlag "capitalize" :> Get Person - :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get Person +type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person + :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person + :<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person + :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person matrixParamApi :: Proxy MatrixParamApi matrixParamApi = Proxy @@ -323,6 +323,11 @@ postSpec = do it "correctly rejects invalid request bodies with status 400" $ do post' "/" "some invalid body" `shouldRespondWith` 400 + it "responds with 415 if the requested media type is unsupported" $ do + let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType + , "application/nonsense")] + post'' "/" "anything at all" `shouldRespondWith` 415 + type RawApi = "foo" :> Raw rawApi :: Proxy RawApi