From 380acb3efa5e0162fd87519abae893fc67da3244 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 12 Jan 2015 15:08:41 +0100 Subject: [PATCH 1/7] Add Accept header handling. --- default.nix | 15 +++ servant-server.cabal | 2 + src/Servant/Server/ContentTypes.hs | 114 +++++++++++++++++++++ src/Servant/Server/Internal.hs | 53 ++++++---- test/Servant/Server/ContentTypesSpec.hs | 129 ++++++++++++++++++++++++ test/Servant/ServerSpec.hs | 19 ++-- test/Servant/Utils/StaticFilesSpec.hs | 3 +- 7 files changed, 308 insertions(+), 27 deletions(-) create mode 100644 default.nix create mode 100644 src/Servant/Server/ContentTypes.hs create mode 100644 test/Servant/Server/ContentTypesSpec.hs diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..e8a420df --- /dev/null +++ b/default.nix @@ -0,0 +1,15 @@ +{ pkgs ? import { config.allowUnfree = true; } +, src ? builtins.filterSource (path: type: + type != "unknown" && + baseNameOf path != ".git" && + baseNameOf path != "result" && + baseNameOf path != "dist") ./. +, servant ? import ../servant {} +}: +pkgs.haskellPackages.buildLocalCabalWithArgs { + name = "servant-server"; + inherit src; + args = { + inherit servant; + }; +} diff --git a/servant-server.cabal b/servant-server.cabal index 7da021e7..077f63ea 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -31,6 +31,7 @@ library exposed-modules: Servant Servant.Server + Servant.Server.ContentTypes Servant.Server.Internal Servant.Utils.StaticFiles build-depends: @@ -41,6 +42,7 @@ library , either >= 4.3 , http-types , network-uri >= 2.6 + , http-media == 0.4.* , safe , servant >= 0.2.2 , split diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs new file mode 100644 index 00000000..e714421d --- /dev/null +++ b/src/Servant/Server/ContentTypes.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.ContentTypes where + +import Data.Aeson (ToJSON(..), encode) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as BS +import Data.Proxy (Proxy(..)) +import Data.String.Conversions (cs) +import qualified Network.HTTP.Media as M + + +import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText) + +-- | 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 + +instance Accept HTML where + contentType _ = "text" M.// "html" + +instance Accept JSON where + contentType _ = "application" M.// "json" + +instance Accept XML where + contentType _ = "application" M.// "xml" + +instance Accept JavaScript where + contentType _ = "application" M.// "javascript" + +instance Accept CSS where + contentType _ = "text" M.// "css" + +instance Accept PlainText where + contentType _ = "text" M.// "plain" + +newtype AcceptHeader = AcceptHeader BS.ByteString + deriving (Eq, Show) + +-- | Instantiate this class to register a way of serializing a type based +-- on the @Accept@ header. +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, IsEmpty ctyps ~ 'False + ) => 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 + + +-------------------------------------------------------------------------- +-- 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 + +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 + , 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 _ _ = [] + +type family IsEmpty (ls::[*]) where + IsEmpty '[] = 'True + IsEmpty x = 'False + +-------------------------------------------------------------------------- +-- MimeRender Instances +-------------------------------------------------------------------------- + +instance ToJSON a => MimeRender JSON a where + toByteString _ = encode + +instance Show a => MimeRender PlainText a where + toByteString _ = encode . show + +instance MimeRender PlainText String where + toByteString _ = encode diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 4bd0a08b..033129b4 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -24,10 +24,14 @@ import qualified Data.Text as T import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header) -import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody, - strictRequestBody, lazyRequestBody, requestHeaders, requestMethod, +import Network.Wai ( Response, Request, ResponseReceived, Application + , pathInfo, requestBody, strictRequestBody + , lazyRequestBody, requestHeaders, requestMethod, rawQueryString, responseLBS) -import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) +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.Common.Text (FromText, fromText) data ReqBodyState = Uncalled @@ -225,7 +229,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) _ -> respond $ failWith NotFound where captureProxy = Proxy :: Proxy (Capture capture a) - + -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete @@ -264,14 +268,19 @@ instance HasServer Delete where -- 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 ToJSON result => HasServer (Get result) where - type Server (Get result) = EitherT (Int, String) IO result +instance ( AllCTRender ctypes a, ToJSON a + ) => HasServer (Get ctypes a) where + type Server (Get ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action respond . succeedWith $ case e of - Right output -> - responseLBS ok200 [("Content-Type", "application/json")] (encode output) + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> responseLBS (mkStatus 406 "") [] "" + Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" + , cs contentT)] body Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodGet = @@ -321,15 +330,20 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) -- 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 ToJSON a => HasServer (Post a) where - type Server (Post a) = EitherT (Int, String) IO a +instance ( AllCTRender ctypes a, ToJSON a + )=> HasServer (Post ctypes a) where + type Server (Post 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 -> - responseLBS status201 [("Content-Type", "application/json")] (encode out) + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> responseLBS (mkStatus 406 "") [] "" + Just (contentT, body) -> responseLBS status201 [ ("Content-Type" + , cs contentT)] body Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPost = @@ -347,15 +361,20 @@ instance ToJSON a => HasServer (Post a) where -- 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 ToJSON a => HasServer (Put a) where - type Server (Put a) = EitherT (Int, String) IO a +instance ( AllCTRender ctypes a, ToJSON a + ) => HasServer (Put ctypes a) where + type Server (Put ctypes a) = EitherT (Int, String) IO a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action respond . succeedWith $ case e of - Right out -> - responseLBS ok200 [("Content-Type", "application/json")] (encode out) + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> responseLBS (mkStatus 406 "") [] "" + Just (contentT, body) -> responseLBS status200 [ ("Content-Type" + , cs contentT)] body Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPut = @@ -382,7 +401,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where e <- runEitherT action respond . succeedWith $ case e of Right out -> case cast out of - Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out) + Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out) Just () -> responseLBS status204 [] "" Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs new file mode 100644 index 00000000..8d725f18 --- /dev/null +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Server.ContentTypesSpec where + +import Control.Applicative +import Data.Aeson (encode) +import Data.ByteString.Char8 +import Data.Function (on) +import Data.Maybe (isJust, fromJust) +import Data.List (maximumBy) +import Data.Proxy (Proxy(..)) +import Data.String (IsString(..)) +import Data.String.Conversions (cs) +import Network.HTTP.Types (hAccept) +import Network.Wai (pathInfo, requestHeaders) +import Network.Wai.Test ( runSession, request, defaultRequest + , assertContentType, assertStatus ) +import Test.Hspec +import Test.QuickCheck + +import Servant.API +import Servant.Server +import Servant.Server.ContentTypes + + +spec :: Spec +spec = describe "Servant.Server.ContentTypes" $ do + handleAcceptHSpec + contentTypeSpec + +handleAcceptHSpec :: Spec +handleAcceptHSpec = describe "handleAcceptH" $ do + + it "should return Just if the 'Accept' header matches" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) + `shouldSatisfy` isJust + + it "should return the Content-Type as the first element of the tuple" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` ((== "application/json") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) + `shouldSatisfy` ((== "text/html") . fst . fromJust) + + it "should return the appropriately serialized representation" $ do + property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) + == Just ("application/json", encode x) + + it "respects the Accept spec ordering" $ + property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) + where + highest a b c = maximumBy (compare `on` snd) [ ("text/html", a) + , ("application/json", b) + , ("application/xml", c) + ] + acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ + addToAccept (Proxy :: Proxy JSON) b $ + addToAccept (Proxy :: Proxy XML ) c "" + val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML]) + (acceptH a b c) (i :: Int) + +type ContentTypeApi = "foo" :> Get '[JSON] Int + :<|> "bar" :> Get '[JSON, PlainText] Int + +contentTypeApi :: Proxy ContentTypeApi +contentTypeApi = Proxy + +contentTypeServer :: Server ContentTypeApi +contentTypeServer = return 5 :<|> return 3 + +contentTypeSpec :: Spec +contentTypeSpec = do + describe "Accept Headers" $ do + + it "uses the highest quality possible in the header" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + let acceptH = "text/plain; q=0.9, application/json; q=0.8" + response <- Network.Wai.Test.request defaultRequest{ + requestHeaders = [(hAccept, acceptH)] , + pathInfo = ["bar"] + } + assertContentType "text/plain" response + + it "returns the first content-type if the Accept header is missing" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["bar"] + } + assertContentType "application/json" response + + it "returns 406 if it can't serve the requested content-type" $ + flip runSession (serve contentTypeApi contentTypeServer) $ do + let acceptH = "text/css" + response <- Network.Wai.Test.request defaultRequest{ + requestHeaders = [(hAccept, acceptH)] , + pathInfo = ["bar"] + } + assertStatus 406 response + + +instance Show a => MimeRender HTML a where + toByteString _ = cs . show + +instance Show a => MimeRender XML a where + toByteString _ = cs . show + +instance IsString AcceptHeader where + fromString = AcceptHeader . fromString + +addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader +addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) + where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) + cont "" = new + cont old = old `append` ", " `append` new + +newtype ZeroToOne = ZeroToOne Float + deriving (Eq, Show, Ord) + +instance Arbitrary ZeroToOne where + arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index ee3a8d22..c173c3ae 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -22,6 +22,7 @@ import Network.Wai.Test (runSession, request, defaultRequest, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus) +import Servant.API (JSON) import Servant.API.Capture (Capture) import Servant.API.Get (Get) import Servant.API.ReqBody (ReqBody) @@ -79,7 +80,7 @@ spec = do errorsSpec -type CaptureApi = Capture "legs" Integer :> Get Animal +type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy captureServer :: Integer -> EitherT (Int, String) IO Animal @@ -105,7 +106,7 @@ captureSpec = do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -type GetApi = Get Person +type GetApi = Get '[JSON] Person getApi :: Proxy GetApi getApi = Proxy @@ -123,9 +124,9 @@ getSpec = do post "/" "" `shouldRespondWith` 405 -type QueryParamApi = QueryParam "name" String :> Get Person - :<|> "a" :> QueryParams "names" String :> Get Person - :<|> "b" :> QueryFlag "capitalize" :> Get Person +type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person + :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person + :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy @@ -289,8 +290,8 @@ matrixParamSpec = do } type PostApi = - ReqBody Person :> Post Integer - :<|> "bla" :> ReqBody Person :> Post Integer + ReqBody Person :> Post '[JSON] Integer + :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer postApi :: Proxy PostApi postApi = Proxy @@ -344,8 +345,8 @@ rawSpec = do type AlternativeApi = - "foo" :> Get Person - :<|> "bar" :> Get Animal + "foo" :> Get '[JSON] Person + :<|> "bar" :> Get '[JSON] Animal unionApi :: Proxy AlternativeApi unionApi = Proxy diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index 6918448f..4d4b2420 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -13,6 +13,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, describe, it, around_) import Test.Hspec.Wai (with, get, shouldRespondWith) +import Servant.API (JSON) import Servant.API.Alternative ((:<|>)((:<|>))) import Servant.API.Capture (Capture) import Servant.API.Get (Get) @@ -23,7 +24,7 @@ import Servant.ServerSpec (Person(Person)) import Servant.Utils.StaticFiles (serveDirectory) type Api = - "dummy_api" :> Capture "person_name" String :> Get Person + "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person :<|> "static" :> Raw From 8028cceee72fc2beaff1fda54912c654f41320b1 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 13 Jan 2015 20:40:41 +0100 Subject: [PATCH 2/7] ReqBody content types. --- CHANGELOG.md | 5 ++ example/greet.hs | 6 +- servant-server.cabal | 36 ++++----- src/Servant/Server.hs | 9 ++- src/Servant/Server/ContentTypes.hs | 115 +++++++++++++++++++++++++---- src/Servant/Server/Internal.hs | 71 +++++++++++------- test/Servant/ServerSpec.hs | 28 ++++--- 7 files changed, 195 insertions(+), 75 deletions(-) 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 From 2092ddc20142ca03575fcb8f603932f871206349 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 13 Jan 2015 22:40:41 +0100 Subject: [PATCH 3/7] Charset test fixes. --- src/Servant/Server/ContentTypes.hs | 22 ++++++++++++---------- test/Servant/Server/ContentTypesSpec.hs | 23 ++++++++++++----------- test/Servant/ServerSpec.hs | 2 +- 3 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs index 5ca8989f..b32ae124 100644 --- a/src/Servant/Server/ContentTypes.hs +++ b/src/Servant/Server/ContentTypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,6 +18,7 @@ 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 GHC.Exts (Constraint) import qualified Network.HTTP.Media as M @@ -39,7 +41,7 @@ class Accept ctype where -- | @text/html;charset=utf-8@ instance Accept HTML where - contentType _ = "text" M.// "html" + contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -- | @application/json;charset=utf-8@ instance Accept JSON where @@ -47,19 +49,19 @@ instance Accept JSON where -- | @application/xml;charset=utf-8@ instance Accept XML where - contentType _ = "application" M.// "xml" + contentType _ = "application" M.// "xml" M./: ("charset", "utf-8") -- | @application/javascript;charset=utf-8@ instance Accept JavaScript where - contentType _ = "application" M.// "javascript" + contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8") -- | @text/css;charset=utf-8@ instance Accept CSS where - contentType _ = "text" M.// "css" + contentType _ = "text" M.// "css" M./: ("charset", "utf-8") -- | @text/plain;charset=utf-8@ instance Accept PlainText where - contentType _ = "text" M.// "plain" + contentType _ = "text" M.// "plain" M./: ("charset", "utf-8") -- | @application/octet-stream@ instance Accept OctetStream where @@ -93,7 +95,7 @@ class AllCTRender list a where -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False +instance ( AllMimeRender ctyps a, IsNonEmpty ctyps ) => AllCTRender ctyps a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy ctyps @@ -125,7 +127,7 @@ class AllCTUnrender list a where -> ByteString -- Request body -> Maybe a -instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False +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 @@ -182,9 +184,9 @@ instance ( MimeUnrender ctyp a pctyps = Proxy :: Proxy ctyps pctyp' = Proxy :: Proxy ctyp' -type family IsEmpty (ls::[*]) where - IsEmpty '[] = 'True - IsEmpty x = 'False +type family IsNonEmpty (ls::[*]) :: Constraint where + IsNonEmpty '[] = 'False ~ 'True + IsNonEmpty x = () -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs index 8d725f18..657f8860 100644 --- a/test/Servant/Server/ContentTypesSpec.hs +++ b/test/Servant/Server/ContentTypesSpec.hs @@ -13,6 +13,7 @@ import Data.Function (on) import Data.Maybe (isJust, fromJust) import Data.List (maximumBy) import Data.Proxy (Proxy(..)) +import qualified Data.Text.Lazy as T import Data.String (IsString(..)) import Data.String.Conversions (cs) import Network.HTTP.Types (hAccept) @@ -45,22 +46,22 @@ handleAcceptHSpec = describe "handleAcceptH" $ do it "should return the Content-Type as the first element of the tuple" $ do handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json") . fst . fromJust) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` ((== "text/html") . fst . fromJust) + `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust) it "should return the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) - == Just ("application/json", encode x) + == Just ("application/json;charset=utf-8", encode x) it "respects the Accept spec ordering" $ property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) where - highest a b c = maximumBy (compare `on` snd) [ ("text/html", a) - , ("application/json", b) - , ("application/xml", c) + highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a) + , ("application/json;charset=utf-8", b) + , ("application/xml;charset=utf-8", c) ] acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ addToAccept (Proxy :: Proxy JSON) b $ @@ -69,13 +70,13 @@ handleAcceptHSpec = describe "handleAcceptH" $ do (acceptH a b c) (i :: Int) type ContentTypeApi = "foo" :> Get '[JSON] Int - :<|> "bar" :> Get '[JSON, PlainText] Int + :<|> "bar" :> Get '[JSON, PlainText] T.Text contentTypeApi :: Proxy ContentTypeApi contentTypeApi = Proxy contentTypeServer :: Server ContentTypeApi -contentTypeServer = return 5 :<|> return 3 +contentTypeServer = return 5 :<|> return "hi" contentTypeSpec :: Spec contentTypeSpec = do @@ -88,14 +89,14 @@ contentTypeSpec = do requestHeaders = [(hAccept, acceptH)] , pathInfo = ["bar"] } - assertContentType "text/plain" response + assertContentType "text/plain;charset=utf8" response it "returns the first content-type if the Accept header is missing" $ flip runSession (serve contentTypeApi contentTypeServer) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["bar"] } - assertContentType "application/json" response + assertContentType "application/json;charset=utf8" response it "returns 406 if it can't serve the requested content-type" $ flip runSession (serve contentTypeApi contentTypeServer) $ do diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 7982e29c..2d82037e 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -303,7 +303,7 @@ 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")] + , "application/json;charset=utf-8")] it "allows to POST a Person" $ do post' "/" (encode alice) `shouldRespondWith` "42"{ From e9f3341b9e4e08116f5fb4396ed2cc3c7130adc7 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 19 Feb 2015 19:18:43 +0100 Subject: [PATCH 4/7] 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 From 0789682cf80971e359b49e419bbd519cdc755757 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Sat, 21 Feb 2015 18:05:31 +0100 Subject: [PATCH 5/7] Remove ContentTypes.hs --- servant-server.cabal | 2 - src/Servant.hs | 2 - src/Servant/Server.hs | 1 - src/Servant/Server/ContentTypes.hs | 51 --------- test/Servant/Server/ContentTypesSpec.hs | 131 ------------------------ 5 files changed, 187 deletions(-) delete mode 100644 src/Servant/Server/ContentTypes.hs delete mode 100644 test/Servant/Server/ContentTypesSpec.hs diff --git a/servant-server.cabal b/servant-server.cabal index b4b2b3ab..8061a0ba 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -31,7 +31,6 @@ library exposed-modules: Servant Servant.Server - Servant.Server.ContentTypes Servant.Server.Internal Servant.Utils.StaticFiles build-depends: @@ -40,7 +39,6 @@ library , 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 diff --git a/src/Servant.hs b/src/Servant.hs index 0a92f8dd..38671f34 100644 --- a/src/Servant.hs +++ b/src/Servant.hs @@ -8,7 +8,6 @@ module Servant ( -- | Using your types in request paths and query string parameters module Servant.Common.Text, -- | Utilities on top of the servant core - module Servant.QQ, module Servant.Utils.Links, module Servant.Utils.StaticFiles, -- | Useful re-exports @@ -19,6 +18,5 @@ import Data.Proxy import Servant.API import Servant.Common.Text import Servant.Server -import Servant.QQ import Servant.Utils.Links import Servant.Utils.StaticFiles diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index 2495022e..4f8c94a8 100644 --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -16,7 +16,6 @@ import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal -import Servant.Server.ContentTypes () -- * Implementing Servers diff --git a/src/Servant/Server/ContentTypes.hs b/src/Servant/Server/ContentTypes.hs deleted file mode 100644 index 8557dc3c..00000000 --- a/src/Servant/Server/ContentTypes.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Servant.Server.ContentTypes where - -import Control.Monad (join) -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(..)) -import Data.String.Conversions (cs) -import qualified Data.Text.Lazy.Encoding as Text -import qualified Data.Text.Lazy as Text -import GHC.Exts (Constraint) -import qualified Network.HTTP.Media as M - - -import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText - , OctetStream, MimeRender(..), MimeUnrender(..) ) - - --------------------------------------------------------------------------- --- * MimeRender Instances - --- | @encode@ -instance ToJSON a => MimeRender JSON a where - toByteString _ = encode - --- | @encodeUtf8@ -instance MimeRender PlainText Text.Text where - toByteString _ = Text.encodeUtf8 - --------------------------------------------------------------------------- --- * MimeUnrender Instances - --- | @decode@ -instance FromJSON a => MimeUnrender JSON a where - fromByteString _ = eitherDecode - --- | @Text.decodeUtf8'@ -instance MimeUnrender PlainText Text.Text where - fromByteString _ = left show . Text.decodeUtf8' - diff --git a/test/Servant/Server/ContentTypesSpec.hs b/test/Servant/Server/ContentTypesSpec.hs deleted file mode 100644 index a857738b..00000000 --- a/test/Servant/Server/ContentTypesSpec.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Server.ContentTypesSpec where - -import Control.Applicative -import Data.Aeson (encode) -import Data.ByteString.Char8 -import Data.Function (on) -import Data.Maybe (isJust, fromJust) -import Data.List (maximumBy) -import Data.Proxy (Proxy(..)) -import qualified Data.Text.Lazy as T -import Data.String (IsString(..)) -import Data.String.Conversions (cs) -import Network.HTTP.Types (hAccept) -import Network.Wai (pathInfo, requestHeaders) -import Network.Wai.Test ( runSession, request, defaultRequest - , assertContentType, assertStatus ) -import Test.Hspec -import Test.QuickCheck - -import Servant.API -import Servant.API.ContentTypes -import Servant.Server -import Servant.Server.ContentTypes () - - -spec :: Spec -spec = describe "Servant.Server.ContentTypes" $ do - handleAcceptHSpec - contentTypeSpec - -handleAcceptHSpec :: Spec -handleAcceptHSpec = describe "handleAcceptH" $ do - - it "should return Just if the 'Accept' header matches" $ do - handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` isJust - handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` isJust - handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` isJust - - it "should return the Content-Type as the first element of the tuple" $ do - handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) - `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) - handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int) - `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) - handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int) - `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust) - - it "should return the appropriately serialized representation" $ do - property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int) - == Just ("application/json;charset=utf-8", encode x) - - it "respects the Accept spec ordering" $ - property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c) - where - highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a) - , ("application/json;charset=utf-8", b) - , ("application/xml;charset=utf-8", c) - ] - acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $ - addToAccept (Proxy :: Proxy JSON) b $ - addToAccept (Proxy :: Proxy XML ) c "" - val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML]) - (acceptH a b c) (i :: Int) - -type ContentTypeApi = "foo" :> Get '[JSON] Int - :<|> "bar" :> Get '[JSON, PlainText] T.Text - -contentTypeApi :: Proxy ContentTypeApi -contentTypeApi = Proxy - -contentTypeServer :: Server ContentTypeApi -contentTypeServer = return 5 :<|> return "hi" - -contentTypeSpec :: Spec -contentTypeSpec = do - describe "Accept Headers" $ do - - it "uses the highest quality possible in the header" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - let acceptH = "text/plain; q=0.9, application/json; q=0.8" - response <- Network.Wai.Test.request defaultRequest{ - requestHeaders = [(hAccept, acceptH)] , - pathInfo = ["bar"] - } - assertContentType "text/plain;charset=utf8" response - - it "returns the first content-type if the Accept header is missing" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - response <- Network.Wai.Test.request defaultRequest{ - pathInfo = ["bar"] - } - assertContentType "application/json;charset=utf8" response - - it "returns 406 if it can't serve the requested content-type" $ - flip runSession (serve contentTypeApi contentTypeServer) $ do - let acceptH = "text/css" - response <- Network.Wai.Test.request defaultRequest{ - requestHeaders = [(hAccept, acceptH)] , - pathInfo = ["bar"] - } - assertStatus 406 response - - -instance Show a => MimeRender HTML a where - toByteString _ = cs . show - -instance Show a => MimeRender XML a where - toByteString _ = cs . show - -instance IsString AcceptHeader where - fromString = AcceptHeader . fromString - -addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader -addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) - where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) - cont "" = new - cont old = old `append` ", " `append` new - -newtype ZeroToOne = ZeroToOne Float - deriving (Eq, Show, Ord) - -instance Arbitrary ZeroToOne where - arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] From 81c358962498a76b02bd3a45389761726be85d9c Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 24 Feb 2015 14:05:04 +0100 Subject: [PATCH 6/7] Review fix --- src/Servant/Server/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index bb661194..edee67e4 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -276,7 +276,7 @@ instance ( AllCTRender ctypes a Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" + Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] "" Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" , cs contentT)] body Left (status, message) -> From b96a2d214d7069a811a91ccc91f51efcd01eb509 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 24 Feb 2015 14:48:17 +0100 Subject: [PATCH 7/7] Pay down some coverage debt --- test/Servant/ServerSpec.hs | 45 ++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 26eece0f..e73c565e 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -8,6 +8,7 @@ module Servant.ServerSpec where +import Control.Monad (when) import Control.Monad.Trans.Either (EitherT, left) import Data.Aeson (ToJSON, FromJSON, encode, decode') import Data.Char (toUpper) @@ -16,7 +17,8 @@ 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, methodPost, hContentType) +import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost + , methodDelete, hContentType) import Network.Wai ( Application, Request, responseLBS, pathInfo , queryString, rawQueryString ) import Network.Wai.Test (runSession, defaultRequest, simpleBody, request) @@ -24,16 +26,9 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith , matchStatus, request ) -import Servant.API (JSON) -import Servant.API.Capture (Capture) -import Servant.API.Get (Get) -import Servant.API.ReqBody (ReqBody) -import Servant.API.Post (Post) -import Servant.API.QueryParam (QueryParam, QueryParams, QueryFlag) -import Servant.API.MatrixParam (MatrixParam, MatrixParams, MatrixFlag) -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) -import Servant.API.Alternative ((:<|>)((:<|>))) +import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam + , QueryParams, QueryFlag, MatrixParam, MatrixParams + , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete ) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch(..)) @@ -77,6 +72,7 @@ spec = do queryParamSpec matrixParamSpec postSpec + headerSpec rawSpec unionSpec errorsSpec @@ -328,6 +324,33 @@ postSpec = do , "application/nonsense")] post'' "/" "anything at all" `shouldRespondWith` 415 +type HeaderApi a = Header "MyHeader" a :> Delete +headerApi :: Proxy (HeaderApi a) +headerApi = Proxy + +headerSpec :: Spec +headerSpec = describe "Servant.API.Header" $ do + + let expectsInt :: Maybe Int -> EitherT (Int,String) IO () + expectsInt (Just x) = when (x /= 5) $ error "Expected 5" + expectsInt Nothing = error "Expected an int" + + let expectsString :: Maybe String -> EitherT (Int,String) IO () + expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" + expectsString Nothing = error "Expected a string" + + with (return (serve headerApi expectsInt)) $ do + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] + + it "passes the header to the handler (Int)" $ + delete' "/" "" `shouldRespondWith` 204 + + with (return (serve headerApi expectsString)) $ do + let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] + + it "passes the header to the handler (String)" $ + delete' "/" "" `shouldRespondWith` 204 + type RawApi = "foo" :> Raw rawApi :: Proxy RawApi