Move more Content-type logic back to servant.

This commit is contained in:
Julian K. Arni 2015-02-19 19:18:43 +01:00
parent 2092ddc201
commit e9f3341b9e
5 changed files with 46 additions and 191 deletions

View file

@ -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

View file

@ -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'

View file

@ -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@.

View file

@ -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

View file

@ -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