Move more Content-type logic back to servant.
This commit is contained in:
Julian K. Arni
parent
2092ddc201
commit
e9f3341b9e
5 changed files with 46 additions and 191 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
||||
|
|
|
|||
|
|
@ -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@.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue