diff --git a/CHANGELOG.md b/CHANGELOG.md index 6827d2a1..0993fc8f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ master ------ * Added support for matrix parameters, see e.g. http://www.w3.org/DesignIssues/MatrixURIs.html +* Add support for serializing based on Accept header + (https://github.com/haskell-servant/servant-server/issues/9) +* Ignore trailing slashes + (https://github.com/haskell-servant/servant-server/issues/5) + 0.2.3 ----- diff --git a/example/greet.hs b/example/greet.hs index 822559d6..78521af6 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -18,7 +18,7 @@ import Servant -- * Example -- | A greet message data type -newtype Greet = Greet { msg :: Text } +newtype Greet = Greet { _msg :: Text } deriving (Generic, Show) instance FromJSON Greet @@ -27,11 +27,11 @@ instance ToJSON Greet -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON - "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON - :<|> "greet" :> ReqBody Greet :> Post Greet + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete diff --git a/servant-server.cabal b/servant-server.cabal index 077f63ea..b4b2b3ab 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -35,24 +35,24 @@ library Servant.Server.Internal Servant.Utils.StaticFiles build-depends: - base >=4.7 && <5 - , aeson - , attoparsec - , bytestring - , either >= 4.3 - , http-types - , network-uri >= 2.6 - , http-media == 0.4.* - , safe - , servant >= 0.2.2 - , split - , string-conversions - , system-filepath - , text - , transformers - , wai - , wai-app-static >= 3.0.0.6 - , warp + base >= 4.7 && < 5 + , aeson >= 0.7 && < 0.9 + , attoparsec >= 0.12 && < 0.13 + , bytestring >= 0.10 && < 0.11 + , either >= 4.3 && < 4.4 + , http-media >= 0.4 && < 0.5 + , http-types >= 0.8 && < 0.9 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3 && < 0.4 + , servant >= 0.2 && < 0.4 + , split >= 0.2 && < 0.3 + , string-conversions >= 0.3 && < 0.4 + , system-filepath >= 0.4 && < 0.5 + , text >= 1.2 && < 1.3 + , transformers >= 0.3 && < 0.5 + , wai >= 3.0 && < 3.1 + , wai-app-static >= 3.0 && < 3.1 + , warp >= 3.0 && < 3.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 3d8156ae..f7ca559e 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -9,12 +9,17 @@ 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(..)) -- * Implementing Servers @@ -23,8 +28,8 @@ import Servant.Server.Internal -- -- Example: -- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index e714421d..5ca8989f 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -9,15 +9,21 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.ContentTypes where -import Data.Aeson (ToJSON(..), encode) +import Control.Monad (join) +import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import Data.Proxy (Proxy(..)) import Data.String.Conversions (cs) +import qualified Data.Text.Lazy.Encoding as Text +import qualified Data.Text.Lazy as Text import qualified Network.HTTP.Media as M -import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) +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 @@ -25,35 +31,59 @@ import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) -- -- Example: -- --- instance Accept HTML where --- contentType _ = "text" // "html" +-- > 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" +-- | @application/json;charset=utf-8@ instance Accept JSON where - contentType _ = "application" M.// "json" + contentType _ = "application" M.// "json" M./: ("charset", "utf-8") +-- | @application/xml;charset=utf-8@ instance Accept XML where contentType _ = "application" M.// "xml" +-- | @application/javascript;charset=utf-8@ instance Accept JavaScript where contentType _ = "application" M.// "javascript" +-- | @text/css;charset=utf-8@ instance Accept CSS where contentType _ = "text" M.// "css" +-- | @text/plain;charset=utf-8@ instance Accept PlainText where contentType _ = "text" M.// "plain" +-- | @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 @@ -71,18 +101,53 @@ instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs + + +-------------------------------------------------------------------------- +-- * MimeRender Instances + +-- | @encode@ +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +-- | @encodeUtf8@ +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, IsEmpty ctyps ~ 'False + ) => 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 -> [(M.MediaType, ByteString)] -- list of content-types/response pairs + 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 + , 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) @@ -96,19 +161,39 @@ instance ( MimeRender ctyp a 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 IsEmpty (ls::[*]) where IsEmpty '[] = 'True IsEmpty x = 'False -------------------------------------------------------------------------- --- MimeRender Instances --------------------------------------------------------------------------- +-- * MimeUnrender Instances -instance ToJSON a => MimeRender JSON a where - toByteString _ = encode +-- | @decode@ +instance FromJSON a => MimeUnrender JSON a where + fromByteString _ = decode -instance Show a => MimeRender PlainText a where - toByteString _ = encode . show +-- | @Text.decodeUtf8'@ +instance MimeUnrender PlainText Text.Text where + fromByteString _ = either (const Nothing) Just . Text.decodeUtf8' -instance MimeRender PlainText String where - toByteString _ = encode diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 033129b4..fe2ee529 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -31,9 +31,11 @@ import Network.Wai ( Response, Request, ResponseReceived, Application import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header , MatrixParams, MatrixParam, MatrixFlag, , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) -import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..)) +import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..) + , AllCTUnrender(..) ) import Servant.Common.Text (FromText, fromText) + data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString @@ -175,8 +177,8 @@ class HasServer layout where -- represented by @a@ and if it fails tries @b@. You must provide a request -- handler for each route. -- --- > type MyApi = "books" :> Get [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook @@ -207,7 +209,7 @@ captured _ = fromText -- -- Example: -- --- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book -- > -- > server :: Server MyApi -- > server = getBook @@ -265,10 +267,12 @@ instance HasServer Delete where -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. -- --- 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 200 along the way. -instance ( AllCTRender ctypes a, ToJSON a +-- If successfully returning a value, we use the type-level list, combined +-- with the request's @Accept@ header, to encode the value for you +-- (returning a status code of 200). If there was no @Accept@ header or it +-- was @*/*@, we return encode using the first @Content-Type@ type on the +-- list. +instance ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where type Server (Get ctypes a) = EitherT (Int, String) IO a route Proxy action request respond @@ -301,7 +305,7 @@ instance ( AllCTRender ctypes a, ToJSON a -- > deriving (Eq, Show, FromText, ToText) -- > -- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > -- > server :: Server MyApi -- > server = viewReferer @@ -327,11 +331,13 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. -- --- 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 ( AllCTRender ctypes a, ToJSON a - )=> HasServer (Post ctypes a) where +-- If successfully returning a value, we use the type-level list, combined +-- with the request's @Accept@ header, to encode the value for you +-- (returning a status code of 201). If there was no @Accept@ header or it +-- was @*/*@, we return encode using the first @Content-Type@ type on the +-- list. +instance ( AllCTRender ctypes a + ) => HasServer (Post ctypes a) where type Server (Post ctypes a) = EitherT (Int, String) IO a route Proxy action request respond @@ -358,10 +364,12 @@ instance ( AllCTRender ctypes a, ToJSON a -- failure. You can quite handily use 'Control.Monad.Trans.EitherT.left' -- to quickly fail if some conditions are not met. -- --- 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 200 along the way. -instance ( AllCTRender ctypes a, ToJSON a +-- If successfully returning a value, we use the type-level list, combined +-- with the request's @Accept@ header, to encode the value for you +-- (returning a status code of 201). If there was no @Accept@ header or it +-- was @*/*@, we return encode using the first @Content-Type@ type on the +-- list. +instance ( AllCTRender ctypes a ) => HasServer (Put ctypes a) where type Server (Put ctypes a) = EitherT (Int, String) IO a @@ -423,7 +431,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where -- -- Example: -- --- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy @@ -462,7 +470,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- -- Example: -- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooksBy @@ -495,7 +503,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- -- Example: -- --- > type MyApi = "books" :> QueryFlag "published" :> Get [Book] +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] -- > -- > server :: Server MyApi -- > server = getBooks @@ -654,27 +662,38 @@ instance HasServer Raw where -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'ReqBody'. +-- The @Content-Type@ header is inspected, and the list provided is used to +-- attempt deserialization. If the request does not have a @Content-Type@ +-- header, it is treated as @application/octet-stream@. -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- +-- -- All it asks is for a 'FromJSON' instance. -- -- Example: -- --- > type MyApi = "books" :> ReqBody Book :> Post Book +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- > -- > server :: Server MyApi -- > server = postBook -- > where postBook :: Book -> EitherT (Int, String) IO Book -- > postBook book = ...insert into your db... -instance (FromJSON a, HasServer sublayout) - => HasServer (ReqBody a :> sublayout) where +instance ( AllCTUnrender list a, HasServer sublayout + ) => HasServer (ReqBody list a :> sublayout) where - type Server (ReqBody a :> sublayout) = + type Server (ReqBody list a :> sublayout) = a -> Server sublayout route Proxy subserver request respond = do - mrqbody <- eitherDecode' <$> lazyRequestBody request + -- See HTTP RFC 2616, section 7.2.1 + -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 + -- See also "W3C Internet Media Type registration, consistency of use" + -- http://www.w3.org/2001/tag/2002/0129-mime + let contentTypeH = fromMaybe "application/octet-stream" + $ lookup hContentType $ requestHeaders request + 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 diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index c173c3ae..7982e29c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -16,11 +16,13 @@ import Data.Proxy (Proxy(Proxy)) import Data.String (fromString) import Data.String.Conversions (cs) import GHC.Generics (Generic) -import Network.HTTP.Types (parseQuery, ok200, status409) -import Network.Wai (Application, Request, responseLBS, pathInfo, queryString, rawQueryString) -import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) +import Network.HTTP.Types (parseQuery, ok200, status409, methodPost, hContentType) +import Network.Wai ( Application, Request, responseLBS, pathInfo + , queryString, rawQueryString ) +import Network.Wai.Test (runSession, defaultRequest, simpleBody, request) import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus) +import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith + , matchStatus, request ) import Servant.API (JSON) import Servant.API.Capture (Capture) @@ -171,6 +173,7 @@ queryParamSpec = do name = "john" } + it "allows to retrieve value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" @@ -290,8 +293,8 @@ matrixParamSpec = do } type PostApi = - ReqBody Person :> Post '[JSON] Integer - :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer + ReqBody '[JSON] Person :> Post '[JSON] Integer + :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer postApi :: Proxy PostApi postApi = Proxy @@ -299,23 +302,26 @@ postSpec :: Spec postSpec = do describe "Servant.API.Post and .ReqBody" $ do with (return (serve postApi (return . age :<|> return . age))) $ do + let post' x = Test.Hspec.Wai.request methodPost x [(hContentType + , "application/json")] + it "allows to POST a Person" $ do - post "/" (encode alice) `shouldRespondWith` "42"{ + post' "/" (encode alice) `shouldRespondWith` "42"{ matchStatus = 201 } it "allows alternative routes if all have request bodies" $ do - post "/bla" (encode alice) `shouldRespondWith` "42"{ + post' "/bla" (encode alice) `shouldRespondWith` "42"{ matchStatus = 201 } it "handles trailing '/' gracefully" $ do - post "/bla/" (encode alice) `shouldRespondWith` "42"{ + post' "/bla/" (encode alice) `shouldRespondWith` "42"{ matchStatus = 201 } it "correctly rejects invalid request bodies with status 400" $ do - post "/" "some invalid body" `shouldRespondWith` 400 + post' "/" "some invalid body" `shouldRespondWith` 400 type RawApi = "foo" :> Raw @@ -376,7 +382,7 @@ errorsSpec = do let ib = InvalidBody "The body is invalid" let wm = WrongMethod let nf = NotFound - + describe "Servant.Server.Internal.RouteMismatch" $ do it "HttpError > *" $ do ib <> he `shouldBe` he