diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + 0.18.1 ------ diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server -version: 0.18.1 +version: 0.18.2 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web @@ -71,7 +71,7 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends: - servant >= 0.18 && < 0.19.1 + servant >= 0.18.2 && < 0.18.3 , http-api-data >= 0.4.1 && < 0.4.3 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. @@ -159,7 +159,7 @@ , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.8 , hspec-wai >= 0.10.1 && < 0.12 - , QuickCheck >= 2.12.6.1 && < 2.14 + , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 , wai-extra >= 3.0.24.3 && < 3.2 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -71,17 +71,17 @@ import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', - CaptureAll, Description, EmptyAPI, FramingRender (..), - FramingUnrender (..), FromSourceIO (..), Header', If, - IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw, - ReflectMethod (reflectMethod), RemoteHost, ReqBody', - SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', - Summary, ToSourceIO (..), Vault, Verb, NoContentVerb, + CaptureAll, Description, EmptyAPI, Fragment, + FramingRender (..), FramingUnrender (..), FromSourceIO (..), + Header', If, IsSecure (..), NoContentVerb, QueryFlag, + QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod), + RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, + Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), - AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH, - NoContent) + AllMime, MimeRender (..), MimeUnrender (..), NoContent, + canHandleAcceptH) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) @@ -89,8 +89,8 @@ (GetHeaders, Headers, getHeaders, getResponse) import qualified Servant.Types.SourceT as S import Web.HttpApiData - (FromHttpApiData, parseHeader, parseQueryParam, - parseUrlPieces, parseUrlPiece) + (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, + parseUrlPieces) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context @@ -106,6 +106,8 @@ #ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) +import Servant.API.TypeLevel + (AtLeastOneFragment, FragmentUnique) #endif class HasServer api context where @@ -879,6 +881,29 @@ ':$$: 'Text "and" ':$$: 'ShowType b #endif + +-- | Ignore @'Fragment'@ in server handlers. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooks +-- > where getBooks :: Handler [Book] +-- > getBooks = ...return all books... +#ifdef HAS_TYPE_ERROR +instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) +#else +instance (HasServer api context) +#endif + => HasServer (Fragment a1 :> api) context where + type ServerT (Fragment a1 :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + + hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api) -- $setup -- >>> import Servant diff --git a/src/Servant/Server/UVerb.hs b/src/Servant/Server/UVerb.hs --- a/src/Servant/Server/UVerb.hs +++ b/src/Servant/Server/UVerb.hs @@ -51,7 +51,7 @@ AllMime contentTypes, All (IsServerResource contentTypes) as, Unique (Statuses as) -- for consistency with servant-swagger (server would work fine - -- wihtout; client is a bit of a corner case, because it dispatches + -- without; client is a bit of a corner case, because it dispatches -- the parser based on the status code. with this uniqueness -- constraint it won't have to run more than one parser in weird -- corner cases. diff --git a/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/test/Servant/Server/Internal/RoutingApplicationSpec.hs --- a/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -11,7 +11,7 @@ import Prelude () import Prelude.Compat -import Control.Exception hiding +import Control.Exception hiding (Handler) import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -28,7 +28,7 @@ import Test.Hspec.Wai (request, shouldRespondWith, with) -import qualified Data.Text as T +import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -48,12 +48,12 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers, - HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), - NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, - Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, - ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union, - UVerb, Verb, addHeader) + Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, + Headers, HttpVersion, IsSecure (..), JSON, Lenient, + NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, + UVerb, Union, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, respond, serve, @@ -92,6 +92,7 @@ captureSpec captureAllSpec queryParamSpec + fragmentSpec reqBodySpec headerSpec rawSpec @@ -460,6 +461,37 @@ liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice { name = "Alice" } + +-- }}} +------------------------------------------------------------------------------ +-- * fragmentSpec {{{ +------------------------------------------------------------------------------ + +type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person + :<|> "age" :> Fragment Integer :> Get '[JSON] Person + +fragmentApi :: Proxy FragmentApi +fragmentApi = Proxy + +fragServer :: Server FragmentApi +fragServer = fragmentServer :<|> fragAge + where + fragmentServer = return alice + fragAge = return alice + +fragmentSpec :: Spec +fragmentSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + + describe "Servant.API.Fragment" $ do + it "ignores fragment even if it is present in query" $ do + flip runSession (serve fragmentApi fragServer) $ do + response1 <- mkRequest "#Alice" ["name"] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice -- }}} ------------------------------------------------------------------------------