diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,139 @@ [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) +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. + +0.20.3.0 +-------- + +### Significant changes + +- Remove -XStrictData from servant{,-server}'s cabal files [#1780](https://github.com/haskell-servant/servant/issues/1780) [#1781](https://github.com/haskell-servant/servant/pull/1781) + + The addition of -XStrictData to servant.cabal and servant-server.cabal reduced the laziness + of routing, which would trigger unimplemented endpoints using `error` or `undefined`, + despite the fact that these endpoints themselves were not queried. + +### Other changes + +- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811) + + Implement Server-sent events (SSE) for the Servant client using a new + combinator "ServerSentEvents". The raw event messages, accumulated events and + JSON-processed events can be exposed. + +- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804) + + Expose MultiVerb, a more ergonomic way of defining endpoints that return + many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html + +- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800) + + Adding a Host combinator allows servant users to select APIs according + to the Host header provided by clients. + +- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706) +- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778) +- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805) +- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784) + +0.20.2 +---- + +- Fix build of examples/greet.hs. Add "429 Too Many Requests" error. [#1591](https://github.com/haskell-servant/servant/pull/1591) +- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604) + This involves a new instance `HasServer (QueryString :> api) context`. +- Add `MkHandler` pattern synonym [#1732](https://github.com/haskell-servant/servant/issues/1732) [#1733](https://github.com/haskell-servant/servant/pull/1733) + + Add a bidirectional pattern synonym to construct `Handler a` values from `IO + (Either ServerError a)` ones, and match in the other direction. +- Add instance `HasServer (EmptyAPI :> api) context` [#1775](https://github.com/haskell-servant/servant/pull/1775) +- Bugfix - CaptureAll produces [""] for empty paths due to trailing slash. [#1243](https://github.com/haskell-servant/servant/issues/1243) [#1516](https://github.com/haskell-servant/servant/pull/1516) + + CaptureAll resulted in `[""]` for empty paths due to trailing slash. Similar + oddities occurred around these edge cases like `"/"` resulted in `[]` correctly, + but `"//"` resulted in `["", ""]`. This patch simply eliminates the first `""` + in the pathinfo list as taken from the wai response. This might break user + code that relies on personal shims to solve the problem, however simply removing their + workarounds should fix their code as the behavior is now sane. + +0.20 +---- + +- Add API docs for ServerT [#1573](https://github.com/haskell-servant/servant/pull/1573) +- Add Functor instance to AuthHandler. [#1638](https://github.com/haskell-servant/servant/pull/1638) +- Compatibility with GHC 9.6. [#1680](https://github.com/haskell-servant/servant/pull/1680) + +0.19.2 +------ + +Compatibility with GHC 9.4, see [PR #1592](https://github.com/haskell-servant/servant/pull/1592). + +0.19.1 +------ + +- Add `MonadFail` instance for `Handler` wrt [#1545](https://github.com/haskell-servant/servant/issues/1545) +- Support GHC 9.2 [#1525](https://github.com/haskell-servant/servant/issues/1525) +- Add capture hints in `Router` type for debug and display purposes [PR #1556] (https://github.com/haskell-servant/servant/pull/1556) + +0.19 +---- + +### Significant changes + +- Drop support for GHC < 8.6. +- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). +- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. +- Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). +- Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). + +0.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420) + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + +- Configurable error messages for automatic errors thrown by servant, + like "no route" or "could not parse json body" (#1312, #1326, #1327) + + 0.17 ---- @@ -35,7 +168,7 @@ Some APIs need query parameters rewriting, e.g. in order to support for multiple casing (camel, snake, etc) or something to that effect. - This could be easily achieved by using WAI Middleware and modyfing + This could be easily achieved by using WAI Middleware and modifying request's `Query`. But QueryParam, QueryParams and QueryFlag use `rawQueryString`. By using `queryString` rather then `rawQueryString` we can enable such rewritings. @@ -44,7 +177,7 @@ We used `build-type: Custom`, but it's problematic e.g. for cross-compiling. The benefit is small, as the doctests - can be run other ways too (though not so conviniently). + can be run other ways too (though not so conveniently). 0.16.2 ------ diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -16,6 +17,7 @@ import Network.Wai.Handler.Warp import Servant +import Servant.Server.Generic () -- * Example @@ -38,6 +40,14 @@ -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + :<|> NamedRoutes OtherRoutes + +data OtherRoutes mode = OtherRoutes + { version :: mode :- Get '[JSON] Int + , bye :: mode :- "bye" :> Capture "name" Text :> Get '[JSON] Text + } + deriving Generic + testApi :: Proxy TestApi testApi = Proxy @@ -48,9 +58,13 @@ -- -- Each handler runs in the 'Handler' monad. server :: Server TestApi -server = helloH :<|> postGreetH :<|> deleteGreetH +server = helloH :<|> postGreetH :<|> deleteGreetH :<|> otherRoutes + where otherRoutes = OtherRoutes {..} - where helloH name Nothing = helloH name (Just False) + bye name = pure $ "Bye, " <> name <> " !" + version = pure 42 + + helloH name Nothing = helloH name (Just False) helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,9 +1,10 @@ -cabal-version: >=1.10 -name: servant-server -version: 0.17 +cabal-version: 3.0 +name: servant-server +version: 0.20.3.0 +synopsis: + A family of combinators for defining webservices APIs and serving them -synopsis: A family of combinators for defining webservices APIs and serving them -category: Servant, Web +category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . @@ -15,30 +16,79 @@ . -homepage: http://docs.servant.dev/ -bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors -build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.2 +homepage: http://docs.servant.dev/ +bug-reports: http://github.com/haskell-servant/servant/issues +license: BSD-3-Clause +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: + 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors +build-type: Simple +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 + extra-source-files: CHANGELOG.md README.md source-repository head - type: git + type: git location: http://github.com/haskell-servant/servant.git +common extensions + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyDataDecls + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoStarIsType + OverloadedLabels + OverloadedStrings + PackageImports + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + + default-language: Haskell2010 + +common ghc-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -fhide-source-paths -Wno-unused-do-bind -fdicts-strict + -Wno-unticked-promoted-constructors -Werror=unused-imports + -Wunused-packages + library + import: extensions + import: ghc-options exposed-modules: Servant Servant.Server @@ -49,96 +99,94 @@ Servant.Server.Internal.Context Servant.Server.Internal.Delayed Servant.Server.Internal.DelayedIO + Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler - Servant.Server.Internal.Router + Servant.Server.Internal.ResponseRender Servant.Server.Internal.RouteResult + Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles + Servant.Server.UVerb -- deprecated - exposed-modules: - Servant.Utils.StaticFiles + exposed-modules: Servant.Utils.StaticFiles -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: - base >= 4.9 && < 4.14 - , bytestring >= 0.10.8.1 && < 0.11 - , containers >= 0.5.7.1 && < 0.7 - , mtl >= 2.2.2 && < 2.3 - , text >= 1.2.3.0 && < 1.3 - , transformers >= 0.5.2.0 && < 0.6 - , filepath >= 1.4.1.1 && < 1.5 + , base >= 4.16.4.0 && < 4.22 + , bytestring >=0.11 && <0.13 + , constraints >=0.2 && <0.15 + , containers >=0.6.5.1 && <0.9 + , filepath >=1.4.1.1 && <1.6 + , mtl ^>=2.2.2 || ^>=2.3.1 + , text >=1.2.3.0 && <2.2 + , transformers >=0.5.2.0 && <0.7 -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends: - servant >= 0.16 && < 0.17.1 - , http-api-data >= 0.4.1 && < 0.4.2 + , http-api-data >=0.4.1 && <0.7 + , servant >=0.20.2 && <0.21 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - base-compat >= 0.10.5 && < 0.12 - , base64-bytestring >= 1.0.0.1 && < 1.1 - , exceptions >= 0.10.0 && < 0.11 - , http-media >= 0.7.1.3 && < 0.9 - , http-types >= 0.12.2 && < 0.13 - , network-uri >= 2.6.1.0 && < 2.8 - , monad-control >= 1.0.2.3 && < 1.1 - , network >= 2.8 && < 3.2 - , string-conversions >= 0.4.0.1 && < 0.5 - , resourcet >= 1.2.2 && < 1.3 - , tagged >= 0.8.6 && < 0.9 - , transformers-base >= 0.4.5.2 && < 0.5 - , wai >= 3.2.1.2 && < 3.3 - , wai-app-static >= 3.1.6.2 && < 3.2 - , word8 >= 0.1.3 && < 0.2 + , base64-bytestring >=1.0.0.1 && <1.3 + , exceptions >=0.10.0 && <0.11 + , http-media >=0.7.1.3 && <0.9 + , http-types >=0.12.2 && <0.13 + , monad-control >=1.0.2.3 && <1.1 + , network >=2.8 && <3.3 + , resourcet >=1.2.2 && <1.4 + , sop-core >=0.4.0.0 && <0.6 + , tagged >=0.8.6 && <0.9 + , transformers-base >=0.4.5.2 && <0.5 + , wai >=3.2.2.1 && <3.3 + , wai-app-static >=3.1.6.2 && <3.2 + , word8 >=0.1.3 && <0.2 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -Wno-redundant-constraints + hs-source-dirs: src executable greet - main-is: greet.hs + import: extensions + import: ghc-options + main-is: greet.hs hs-source-dirs: example - ghc-options: -Wall - default-language: Haskell2010 build-depends: - base + , base , base-compat - , servant , servant-server - , wai , text + , wai build-depends: - aeson >= 1.4.1.0 && < 1.5 - , warp >= 3.2.25 && < 3.4 + , aeson >=1.4.1.0 && <3 + , warp >=3.2.25 && <3.5 test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs + import: extensions + import: ghc-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs other-modules: - Servant.ArbitraryMonadServerSpec - Servant.Server.ErrorSpec - Servant.Server.Internal.ContextSpec - Servant.Server.Internal.RoutingApplicationSpec - Servant.Server.RouterSpec - Servant.Server.StaticFilesSpec - Servant.Server.StreamingSpec - Servant.Server.UsingContextSpec - Servant.Server.UsingContextSpec.TestCombinators - Servant.HoistSpec - Servant.ServerSpec + Servant.ArbitraryMonadServerSpec + Servant.HoistSpec + Servant.Server.ErrorSpec + Servant.Server.Internal.ContextSpec + Servant.Server.Internal.RoutingApplicationSpec + Servant.Server.RouterSpec + Servant.Server.StaticFilesSpec + Servant.Server.StreamingSpec + Servant.Server.UsingContextSpec + Servant.Server.UsingContextSpec.TestCombinators + Servant.ServerSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base + , base , base-compat , base64-bytestring , bytestring @@ -148,22 +196,17 @@ , safe , servant , servant-server - , string-conversions , text - , transformers - , transformers-compat , wai - -- Additonal dependencies + -- Additional dependencies build-depends: - aeson >= 1.4.1.0 && < 1.5 - , directory >= 1.3.0.0 && < 1.4 - , hspec >= 2.6.0 && < 2.8 - , hspec-wai >= 0.10.1 && < 0.11 - , QuickCheck >= 2.12.6.1 && < 2.14 - , should-not-typecheck >= 2.1.0 && < 2.2 - , temporary >= 1.3 && < 1.4 - , wai-extra >= 3.0.24.3 && < 3.1 + , aeson >=1.4.1.0 && <3 + , directory >=1.3.0.0 && <1.4 + , hspec >=2.6.0 && <2.12 + , hspec-wai >=0.10.1 && <0.12 + , should-not-typecheck >=2.1.0 && <2.2 + , temporary >=1.3 && <1.4 + , wai-extra >=3.0.24.3 && <3.2 - build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && <2.8 + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -10,6 +13,8 @@ ( -- * Run a wai application from an API serve , serveWithContext + , serveWithContextT + , ServerContext , -- * Construct a wai Application from an API toApplication @@ -21,6 +26,7 @@ , emptyServer , Handler (..) , runHandler + , pattern MkHandler -- * Debugging the server layout , layout @@ -35,6 +41,8 @@ -- * Context , Context(..) , HasContextEntry(getContextEntry) + , type (.++) + , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext @@ -78,6 +86,7 @@ , err417 , err418 , err422 + , err429 -- ** 5XX , err500 , err501 @@ -86,9 +95,28 @@ , err504 , err505 + -- * Formatting of errors from combinators + -- + -- | You can configure how Servant will render errors that occur while parsing the request. + + , ErrorFormatter + , NotFoundErrorFormatter + , ErrorFormatters + + , bodyParserErrorFormatter + , urlParseErrorFormatter + , headerParseErrorFormatter + , notFoundErrorFormatter + + , DefaultErrorFormatters + , defaultErrorFormatters + + , getAcceptHeader + -- * Re-exports , Application , Tagged (..) + , module Servant.Server.UVerb ) where @@ -101,10 +129,20 @@ import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.UVerb -- * Implementing Servers +-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'. +-- +-- Typically, this will add default context entries to the context. You shouldn't typically +-- need to worry about these constraints, but if you write a helper function that wraps +-- 'serveWithContext', you might need to include this constraint. +type ServerContext context = + ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) + -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: @@ -129,11 +167,28 @@ serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -serveWithContext :: (HasServer api context) +-- | Like 'serve', but allows you to pass custom context. +-- +-- 'defaultErrorFormatters' will always be appended to the end of the passed context, +-- but if you pass your own formatter, it will override the default one. +serveWithContext :: ( HasServer api context + , ServerContext context + ) => Proxy api -> Context context -> Server api -> Application -serveWithContext p context server = - toApplication (runRouter (route p context (emptyDelayed (Route server)))) +serveWithContext p context = serveWithContextT p context id +-- | A general 'serve' function that allows you to pass a custom context and hoisting function to +-- apply on all routes. +serveWithContextT :: + forall api context m. + (HasServer api context, ServerContext context) => + Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application +serveWithContextT p context toHandler server = + toApplication (runRouter format404 (route p context (emptyDelayed router))) + where + router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server + format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context + -- | Hoist server implementation. -- -- Sometimes our cherished `Handler` monad isn't quite the type you'd like for @@ -183,7 +238,7 @@ -- > │ └─ e/ -- > │ └─• -- > ├─ b/ --- > │ └─ / +-- > │ └─ / -- > │ ├─• -- > │ ┆ -- > │ └─• @@ -200,7 +255,8 @@ -- -- [@─•@] Leaves reflect endpoints. -- --- [@\/@] This is a delayed capture of a path component. +-- [@\/@] This is a delayed capture of a single +-- path component named @x@, of expected type @Int@. -- -- [@\@] This is a part of the API we do not know anything about. -- diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs --- a/src/Servant/Server/Experimental/Auth.hs +++ b/src/Servant/Server/Experimental/Auth.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,6 +15,8 @@ import Control.Monad.Trans (liftIO) +import Data.Kind + (Type) import Data.Proxy (Proxy (Proxy)) import Data.Typeable @@ -37,14 +40,14 @@ -- quite often this is some `User` datatype. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -type family AuthServerData a :: * +type family AuthServerData a :: Type -- | Handlers for AuthProtected resources -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler { unAuthHandler :: r -> Handler usr } - deriving (Generic, Typeable) + deriving (Functor, Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr diff --git a/src/Servant/Server/Generic.hs b/src/Servant/Server/Generic.hs --- a/src/Servant/Server/Generic.hs +++ b/src/Servant/Server/Generic.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 0.14.1 module Servant.Server.Generic ( AsServerT, @@ -15,23 +13,19 @@ genericServeT, genericServeTWithContext, genericServer, - genericServerT, + genericServerT ) where +import Data.Kind + (Type) import Data.Proxy (Proxy (..)) -import Servant.API.Generic import Servant.Server - --- | A type that specifies that an API record contains a server implementation. -data AsServerT (m :: * -> *) -instance GenericMode (AsServerT m) where - type AsServerT m :- api = ServerT api m - -type AsServer = AsServerT Handler +import Servant.API.Generic +import Servant.Server.Internal --- | Transform record of routes into a WAI 'Application'. +-- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. ( HasServer (ToServantApi routes) '[] @@ -45,7 +39,7 @@ -- by providing a transformation to bring each handler back in the 'Handler' -- monad. genericServeT - :: forall (routes :: * -> *) (m :: * -> *). + :: forall (routes :: Type -> Type) (m :: Type -> Type). ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) '[] @@ -63,10 +57,11 @@ -- used by auth-related combinators in servant, e.g to hold auth checks) and the given -- transformation to map all the handlers back to the 'Handler' monad. genericServeTWithContext - :: forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]). + :: forall (routes :: Type -> Type) (m :: Type -> Type) (ctx :: [Type]). ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) ctx + , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) ) => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' @@ -80,15 +75,20 @@ p = genericApi (Proxy :: Proxy routes) pctx = Proxy :: Proxy ctx --- | Transform record of endpoints into a 'Server'. +-- | Transform a record of endpoints into a 'Server'. genericServer :: GenericServant routes AsServer => routes AsServer -> ToServant routes AsServer genericServer = toServant +-- | Transform a record of endpoints into a @'ServerT' m@. +-- +-- You can see an example usage of this function +-- . genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m) -> ToServant routes (AsServerT m) genericServerT = toServant + 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 @@ -1,22 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 -#define HAS_TYPE_ERROR -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} module Servant.Server.Internal ( module Servant.Server.Internal @@ -24,6 +7,7 @@ , module Servant.Server.Internal.Context , module Servant.Server.Internal.Delayed , module Servant.Server.Internal.DelayedIO + , module Servant.Server.Internal.ErrorFormatter , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RouteResult @@ -32,82 +16,88 @@ ) where import Control.Monad - (join, when) + (join, when, unless) import Control.Monad.Trans - (liftIO) + (liftIO, lift) import Control.Monad.Trans.Resource - (runResourceT) + (runResourceT, ReleaseKey) +import Data.Acquire import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BSL +import Data.Constraint (Constraint, Dict(..)) import Data.Either (partitionEithers) +import Data.Kind + (Type) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) -import Data.Semigroup - ((<>)) import Data.String (IsString (..)) -import Data.String.Conversions - (cs) import Data.Tagged (Tagged (..), retag, untag) import qualified Data.Text as T import Data.Typeable -import GHC.TypeLits - (KnownNat, KnownSymbol, natVal, symbolVal) +import GHC.Generics +import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding - (Header, ResponseHeaders) + (statusCode, Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai - (Application, Request, httpVersion, isSecure, lazyRequestBody, - queryString, remoteHost, requestBody, requestHeaders, + (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody, + queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestHeaderHost, requestMethod, responseLBS, responseStream, vault) -import Prelude () -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, - WithNamedContext) + CaptureAll, DeepQuery, Description, EmptyAPI, Fragment, + FramingRender (..), FramingUnrender (..), FromSourceIO (..), + Host, Header', If, IsSecure (..), NoContentVerb, QueryFlag, + QueryParam', QueryParams, QueryString, Raw, RawM, ReflectMethod (reflectMethod), + RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, + Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, + WithNamedContext, WithResource, NamedRoutes) +import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant) 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) +import Servant.API.QueryString (FromDeepQuery(..)) import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.API.Status + (statusFromNat) import qualified Servant.Types.SourceT as S +import Servant.API.TypeErrors import Web.HttpApiData - (FromHttpApiData, parseHeader, parseQueryParam, - parseUrlPieces, parseUrlPiece) + (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, + parseUrlPieces) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.Delayed import Servant.Server.Internal.DelayedIO +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError - -#ifdef HAS_TYPE_ERROR -import GHC.TypeLits - (ErrorMessage (..), TypeError) -#endif +import Servant.Server.Internal.ResponseRender +import Servant.API.MultiVerb +import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) class HasServer api context where - type ServerT api (m :: * -> *) :: * + -- | The type of a server for this API, given a monad to run effects in. + -- + -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike + -- what the @T@ in the name might suggest. + type ServerT api (m :: Type -> Type) :: Type route :: Proxy api @@ -168,7 +158,10 @@ -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods)) +instance (KnownSymbol capture, FromHttpApiData a, Typeable a + , HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (Capture' mods capture a :> api) context where type ServerT (Capture' mods capture a :> api) m = @@ -177,15 +170,19 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d = - CaptureRouter $ + CaptureRouter [hint] $ route (Proxy :: Proxy api) context - (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods) - , parseUrlPiece txt :: Either T.Text a) of - (SFalse, Left e) -> delayedFail err400 { errBody = cs e } - (SFalse, Right v) -> return v - (STrue, piece) -> return $ (either (Left . cs) Right) piece - ) + (addCapture d $ \ txt -> withRequest $ \ request -> + case ( sbool :: SBool (FoldLenient mods) + , parseUrlPiece txt :: Either T.Text a) of + (SFalse, Left e) -> delayedFail $ formatError rep request $ T.unpack e + (SFalse, Right v) -> return v + (STrue, piece) -> return $ either (Left . T.unpack) Right piece) + where + rep = typeRep (Proxy :: Proxy Capture') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a)) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a @@ -204,7 +201,10 @@ -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) +instance (KnownSymbol capture, FromHttpApiData a, Typeable a + , HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (CaptureAll capture a :> api) context where type ServerT (CaptureAll capture a :> api) m = @@ -213,15 +213,55 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context d = - CaptureAllRouter $ + CaptureAllRouter [hint] $ route (Proxy :: Proxy api) context - (addCapture d $ \ txts -> case parseUrlPieces txts of - Left _ -> delayedFail err400 - Right v -> return v + (addCapture d $ \ txts -> withRequest $ \ request -> + case parseUrlPieces txts of + Left e -> delayedFail $ formatError rep request $ T.unpack e + Right v -> return v ) + where + rep = typeRep (Proxy :: Proxy CaptureAll) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a])) +-- | If you use 'WithResource' in one of the endpoints for your API Servant +-- will provide the handler for this endpoint an argument of the specified type. +-- The lifespan of this resource will be automatically managed by Servant. This +-- resource will be created before the handler starts and it will be destoyed +-- after it ends. A new resource is created for each request to the endpoint. +-- The creation and destruction are done using a 'Data.Acquire.Acquire' +-- provided via server 'Context'. +-- +-- Example +-- +-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent +-- > +-- > server :: Server MyApi +-- > server = writeToFile +-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent +-- > writeToFile (_, h) = hPutStrLn h "message" +-- +-- In addition to the resource, the handler will also receive a 'ReleaseKey' +-- which can be used to deallocate the resource before the end of the request +-- if desired. + +instance (HasServer api ctx, HasContextEntry ctx (Acquire a)) + => HasServer (WithResource a :> api) ctx where + + type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s + + route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource) + where + allocateResource :: DelayedIO (ReleaseKey, a) + allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context) + + + allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -240,10 +280,10 @@ -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () +acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return () - | otherwise = delayedFail err406 + | canHandleAcceptH proxy accH = return () + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (b -> ([(HeaderName, B.ByteString)], a)) @@ -253,16 +293,16 @@ methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond = - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let accH = getAcceptHeader request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let (headers, b) = splitHeaders output - case handleAcceptH proxy (AcceptHeader accH) b of + case handleAcceptH proxy accH b of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> let bdy = if allowedMethodHead method request then "" else body - in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy + in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy noContentRouter :: Method -> Status @@ -284,7 +324,7 @@ route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status @@ -296,7 +336,7 @@ route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance (ReflectMethod method) => HasServer (NoContentVerb method) context where @@ -317,7 +357,7 @@ route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) instance {-# OVERLAPPING #-} @@ -331,7 +371,7 @@ route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = statusFromNat (Proxy :: Proxy status) streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => @@ -343,7 +383,7 @@ -> Delayed env (Handler c) -> Router env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) @@ -352,7 +392,7 @@ ) env request respond $ \ output -> let (headers, fa) = splitHeaders output sourceT = toSourceIO fa - S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT + S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BSL.ByteString) sourceT in Route $ responseStream status (contentHeader : headers) $ \write flush -> do let loop S.Stop = flush loop (S.Error err) = fail err -- TODO: throw better error @@ -388,6 +428,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (Header' mods sym a :> api) context where ------ @@ -399,6 +440,9 @@ route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where + rep = typeRep (Proxy :: Proxy Header') + formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + headerName :: IsString n => n headerName = fromString $ symbolVal (Proxy :: Proxy sym) @@ -409,16 +453,38 @@ mev :: Maybe (Either T.Text a) mev = fmap parseHeader $ lookup headerName (requestHeaders req) - errReq = delayedFailFatal err400 - { errBody = "Header " <> headerName <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ "Header " <> headerName <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing header " - <> headerName - <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ T.unpack $ "Error parsing header " + <> headerName + <> " failed: " <> e +instance + ( KnownSymbol sym + , HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (Host sym :> api) context where + type ServerT (Host sym :> api) m = ServerT api m + + hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api) + + route _ context (Delayed {..}) = route (Proxy :: Proxy api) context $ + let formatError = + headerParseErrorFormatter $ getContextEntry $ mkContextWithErrorFormatter context + rep = typeRep (Proxy :: Proxy Host) + targetHost = symbolVal (Proxy :: Proxy sym) + hostCheck :: DelayedIO () + hostCheck = withRequest $ \req -> + case requestHeaderHost req of + Just hostBytes -> + let host = BC8.unpack hostBytes + in unless (host == targetHost) $ + delayedFail $ formatError rep req $ "Invalid host: " ++ host + _ -> delayedFail $ formatError rep req "Host header missing" + in Delayed { headersD = headersD <* hostCheck, .. } + -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. @@ -443,6 +509,7 @@ instance ( KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (QueryParam' mods sym a :> api) context where ------ @@ -453,8 +520,11 @@ route Proxy context subserver = let querytext = queryToQueryText . queryString - paramname = cs $ symbolVal (Proxy :: Proxy sym) + paramname = T.pack $ symbolVal (Proxy :: Proxy sym) + rep = typeRep (Proxy :: Proxy QueryParam') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + parseParam :: Request -> DelayedIO (RequestArgument mods a) parseParam req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev @@ -462,14 +532,12 @@ mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req - errReq = delayedFailFatal err400 - { errBody = cs $ "Query parameter " <> paramname <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ T.unpack $ "Query parameter " <> paramname <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter " - <> paramname <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ T.unpack $ "Error parsing query parameter " + <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req @@ -495,7 +563,8 @@ -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters) => HasServer (QueryParams sym a :> api) context where type ServerT (QueryParams sym a :> api) m = @@ -506,21 +575,23 @@ route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where - paramname = cs $ symbolVal (Proxy :: Proxy sym) + rep = typeRep (Proxy :: Proxy QueryParams) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + + paramname = T.pack $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed - (errs, _) -> delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter(s) " - <> paramname <> " failed: " - <> T.intercalate ", " errs - } + (errs, _) -> delayedFailFatal $ formatError rep req + $ T.unpack $ "Error parsing query parameter(s) " + <> paramname <> " failed: " + <> T.intercalate ", " errs where params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) - . queryToQueryText - . queryString + . queryToQueryText + . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") @@ -552,10 +623,109 @@ Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string in route (Proxy :: Proxy api) context (passToServer subserver param) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) + where paramname = T.pack $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False +-- | If you use @'QueryString'@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @Query@ (@[('ByteString', 'Maybe' 'ByteString')]@). +-- +-- This lets you extract the whole query string. This is useful when the query string +-- can contain parameters with dynamic names, that you can't access with @'QueryParam'@. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryString :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: Query -> Handler [Book] +-- > getBooksBy filters = ...filter books based on the dynamic filters provided... +instance + ( HasServer api context + ) + => HasServer (QueryString :> api) context where +------ + type ServerT (QueryString :> api) m = + Query -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver queryString) + +-- | If you use @'DeepQuery' "symbol" a@ in one of the endpoints for your API, +-- this automatically requires your server-side handler to be a function +-- that takes an argument of type @a@. +-- +-- This lets you extract an object from multiple parameters in the query string, +-- with its fields enclosed in brackets: `/books?filter[author][name]=value`. When +-- all the fields are known in advance, it can be done with @'QueryParam'@ (it can +-- still be tedious if you the object has many fields). When some fields are dynamic, +-- it cannot be done with @'QueryParam'. +-- +-- The way the object is constructed from the extracted fields can be controlled by +-- providing an instance on @'FromDeepQuery'@ +-- +-- Example: +-- +-- > type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooksBy +-- > where getBooksBy :: BookQuery -> Handler [Book] +-- > getBooksBy query = ...filter books based on the dynamic filters provided... +instance + ( KnownSymbol sym, FromDeepQuery a, HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) + => HasServer (DeepQuery sym a :> api) context where +------ + type ServerT (DeepQuery sym a :> api) m = + a -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver = route (Proxy :: Proxy api) context $ + subserver `addParameterCheck` withRequest paramsCheck + where + rep = typeRep (Proxy :: Proxy DeepQuery) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + + paramname = T.pack $ symbolVal (Proxy :: Proxy sym) + paramsCheck req = + let relevantParams :: [(T.Text, Maybe T.Text)] + relevantParams = mapMaybe isRelevantParam + . queryToQueryText + . queryString + $ req + isRelevantParam (name, value) = (, value) <$> + case T.stripPrefix paramname name of + Just "" -> Just "" + Just x | "[" `T.isPrefixOf` x -> Just x + _ -> Nothing + in case fromDeepQuery =<< traverse parseDeepParam relevantParams of + Left e -> delayedFailFatal $ formatError rep req + $ T.unpack $ "Error parsing deep query parameter(s) " + <> paramname <> T.pack " failed: " + <> T.pack e + Right parsed -> return parsed + +parseDeepParam :: (T.Text, Maybe T.Text) -> Either String ([T.Text], Maybe T.Text) +parseDeepParam (paramname, value) = + let parseParam "" = return [] + parseParam n = reverse <$> go [] n + go parsed remaining = case T.take 1 remaining of + "[" -> case T.breakOn "]" remaining of + (_ , "") -> Left $ "Error parsing deep param, missing closing ']': " <> T.unpack remaining + (name, "]") -> return $ T.drop 1 name : parsed + (name, remaining') -> case T.take 2 remaining' of + "][" -> go (T.drop 1 name : parsed) (T.drop 1 remaining') + _ -> Left $ "Error parsing deep param, incorrect brackets: " <> T.unpack remaining + _ -> Left $ "Error parsing deep param, missing opening '[': " <> T.unpack remaining + in (, value) <$> parseParam paramname + -- | Just pass the request to the underlying application and serve its response. -- -- Example: @@ -582,13 +752,42 @@ Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e +-- | Just pass the request to the underlying application and serve its response. +-- +-- Example: +-- +-- > type MyApi = "images" :> Raw +-- > +-- > server :: Server MyApi +-- > server = serveDirectory "/var/www/images" +instance HasServer RawM context where + type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived + + route + :: Proxy RawM + -> Context context + -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env + route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do + routeResult <- runDelayed handleDelayed env request + let respond' = liftIO . respond + liftIO $ case routeResult of + Route handler -> runHandler (handler request (respond . Route)) >>= + \case + Left e -> respond' $ FailFatal e + Right a -> pure a + Fail e -> respond' $ Fail e + FailFatal e -> respond' $ FailFatal e + + hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond) + + -- | 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@ (as specified in --- . +-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)). -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- @@ -604,6 +803,7 @@ -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (ReqBody' mods list a :> api) context where type ServerT (ReqBody' mods list a :> api) m = @@ -615,6 +815,9 @@ = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where + rep = typeRep (Proxy :: Proxy ReqBody') + formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + -- Content-Type check, we only lookup we can try to parse the request body ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 @@ -623,7 +826,7 @@ -- http://www.w3.org/2001/tag/2002/0129-mime let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request - case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of + case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of Nothing -> delayedFail err415 Just f -> return f @@ -633,7 +836,7 @@ case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of - Left e -> delayedFailFatal err400 { errBody = cs e } + Left e -> delayedFailFatal $ formatError rep request e Right v -> return v instance @@ -648,18 +851,17 @@ route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where - ctCheck :: DelayedIO (SourceIO chunk -> a) + ctCheck :: DelayedIO (SourceIO chunk -> IO a) -- TODO: do content-type check ctCheck = return fromSourceIO - bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a + bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a bodyCheck fromRS = withRequest $ \req -> do - let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BSL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk - let body = requestBody req + let body = getRequestBodyChunk req let rs = S.fromAction B.null body - let rs' = fromRS $ framingUnrender' rs - return rs' + liftIO $ fromRS $ framingUnrender' rs -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. @@ -669,7 +871,7 @@ route Proxy context subserver = pathRouter - (cs (symbolVal proxyPath)) + (T.pack (symbolVal proxyPath)) (route (Proxy :: Proxy api) context subserver) where proxyPath = Proxy :: Proxy path hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s @@ -725,12 +927,12 @@ emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer --- | The server for an `EmptyAPI` is `emptyAPIServer`. +-- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi --- > server = emptyAPIServer +-- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer @@ -738,6 +940,13 @@ hoistServerWithContext _ _ _ = retag +-- | Ignore @'EmptyAPI'@ as part of route in server handlers. +instance HasServer api context => HasServer (EmptyAPI :> api) context where + type ServerT (EmptyAPI :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api) + -- | Basic Authentication instance ( KnownSymbol realm , HasServer api context @@ -759,8 +968,11 @@ -- * helpers ct_wildcard :: B.ByteString -ct_wildcard = "*" <> "/" <> "*" -- Because CPP +ct_wildcard = "*" <> "/" <> "*" +getAcceptHeader :: Request -> AcceptHeader +getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders + -- * General Authentication @@ -784,40 +996,20 @@ hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s ------------------------------------------------------------------------------- --- TypeError helpers +-- Custom type errors ------------------------------------------------------------------------------- -#ifdef HAS_TYPE_ERROR --- | This instance catches mistakes when there are non-saturated --- type applications on LHS of ':>'. --- --- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...") --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- --- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int) --- ... --- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'. --- ...Maybe you haven't applied enough arguments to --- ...Capture' '[] "foo" --- ... --- -instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context - where - type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) - -- it doens't really matter what sub route we peak - route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" - hoistServerWithContext _ _ _ = id +-- Erroring instance for 'HasServer' when a combinator is not fully applied +instance TypeError (PartialApplication --- Cannot have TypeError here, otherwise use of this symbol will error :) -type HasServerArrowKindError arr = - 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'." - ':$$: 'Text "Maybe you haven't applied enough arguments to" - ':$$: 'ShowType arr + @(Type -> [Type] -> Constraint) + HasServer arr) => HasServer ((arr :: a -> b) :> sub) context + where + type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: Type -> [Type] -> Constraint) arr) + route = error "unreachable" + hoistServerWithContext _ _ _ _ = error "unreachable" + -- | This instance prevents from accidentally using '->' instead of ':>' -- -- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...") @@ -850,7 +1042,152 @@ ':$$: 'ShowType a ':$$: 'Text "and" ':$$: 'ShowType b -#endif +-- Erroring instances for 'HasServer' for unknown API combinators + +-- XXX: This omits the @context@ parameter, e.g.: +-- +-- "There is no instance for HasServer (Bool :> …)". Do we care ? +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub + + @(Type -> [Type] -> Constraint) + + HasServer ty) => HasServer (ty :> sub) context + +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context + +-- | 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... +instance (AtMostOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) + => 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 + +-- | A type that specifies that an API record contains a server implementation. +data AsServerT (m :: Type -> Type) +instance GenericMode (AsServerT m) where + type AsServerT m :- api = ServerT api m + +type AsServer = AsServerT Handler + + +-- | Set of constraints required to convert to / from vanilla server types. +type GServerConstraints api m = + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) + +-- | This class is a necessary evil: in the implementation of 'HasServer' for +-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall +-- m. 'GServerConstraints' m@ to hold. +-- +-- We cannot require do that directly as the definition of 'GServerConstraints' +-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide +-- those type family applications behind a typeclass providing evidence for +-- @'GServerConstraints' api m@ in the form of a dictionary, and require that +-- @forall m. 'GServer' api m@ instead. +-- +-- Users shouldn't have to worry about this class, as the only possible instance +-- is provided in this module for all record APIs. + +class GServer (api :: Type -> Type) (m :: Type -> Type) where + gServerProof :: Dict (GServerConstraints api m) + +instance + ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m + , GServantProduct (Rep (api (AsServerT m))) + ) => GServer api m where + gServerProof = Dict + +instance + ( HasServer (ToServantApi api) context + , forall m. Generic (api (AsServerT m)) + , forall m. GServer api m + , ErrorIfNoGeneric api + ) => HasServer (NamedRoutes api) context where + + type ServerT (NamedRoutes api) m = api (AsServerT m) + + route + :: Proxy (NamedRoutes api) + -> Context context + -> Delayed env (api (AsServerT Handler)) + -> Router env + route _ ctx delayed = + case gServerProof @api @Handler of + Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed) + + hoistServerWithContext + :: forall m n. Proxy (NamedRoutes api) + -> Proxy context + -> (forall x. m x -> n x) + -> api (AsServerT m) + -> api (AsServerT n) + hoistServerWithContext _ pctx nat server = + case (gServerProof @api @m, gServerProof @api @n) of + (Dict, Dict) -> + fromServant servantSrvN + where + servantSrvM :: ServerT (ToServantApi api) m = + toServant server + servantSrvN :: ServerT (ToServantApi api) n = + hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM + + +instance + ( HasAcceptCheck cs, + ResponseListRender cs as, + AsUnion as r, + ReflectMethod method + ) => + HasServer (MultiVerb method cs as r) ctx + where + type ServerT (MultiVerb method cs as r) m = m r + + hoistServerWithContext _ _ f = f + + route :: + forall env. + Proxy (MultiVerb method cs as r) -> + Context ctx -> + Delayed env (Handler r) -> + Router env + route _ _ action = leafRouter $ \env req k -> do + let acc = getAcceptHeader req + action' = + action + `addMethodCheck` methodCheck method req + `addAcceptCheck` acceptCheck' (Proxy @cs) acc + runAction action' env req k $ \output -> do + let mresp = responseListRender @cs @as acc (toUnion @as output) + someResponseToWai <$> case mresp of + Nothing -> FailFatal err406 + Just resp + | allowedMethodHead method req -> pure (setEmptyBody resp) + | otherwise -> pure resp + where + method = reflectMethod (Proxy @method) + +class HasAcceptCheck cs where + acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO () + +instance (AllMime cs) => HasAcceptCheck cs where + acceptCheck' = acceptCheck + +instance HasAcceptCheck '() where + acceptCheck' _ _ = pure () diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs --- a/src/Servant/Server/Internal/BasicAuth.hs +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -12,8 +12,6 @@ import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) -import Data.Monoid - ((<>)) import Data.Typeable (Typeable) import Data.Word8 @@ -32,7 +30,7 @@ -- * Basic Auth -- | servant-server's current implementation of basic authentication is not --- immune to certian kinds of timing attacks. Decoding payloads does not take +-- immune to certain kinds of timing attacks. Decoding payloads does not take -- a fixed amount of time. -- | The result of authentication/authorization diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/src/Servant/Server/Internal/Context.hs @@ -1,16 +1,23 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.Context where +module Servant.Server.Internal.Context + ( module Servant.Server.Internal.Context + , module Servant.API.TypeLevel.List + ) where +import Data.Kind + (Type) import Data.Proxy import GHC.TypeLits +import Servant.API.TypeLevel.List + (type (.++)) -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace @@ -20,7 +27,7 @@ -- -- If you are using combinators that require a non-empty 'Context' you have to -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all --- the values your combinators need. A 'Context' is essentially a heterogenous +-- the values your combinators need. A 'Context' is essentially a heterogeneous -- list and accessing the elements is being done by type (see 'getContextEntry'). -- The parameter of the type 'Context' is a type-level list reflecting the types -- of the contained context entries. To create a 'Context' with entries, use the @@ -45,6 +52,11 @@ instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 +-- | Append two contexts. +(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2) +EmptyContext .++ a = a +(a :. as) .++ b = a :. (as .++ b) + -- | This class is used to access context entries in 'Context's. 'getContextEntry' -- returns the first value where the type matches: -- @@ -56,9 +68,9 @@ -- -- >>> getContextEntry (True :. False :. EmptyContext) :: String -- ... --- ...No instance for (HasContextEntry '[] [Char]) +-- ...No instance for ...HasContextEntry '[] [Char]... -- ... -class HasContextEntry (context :: [*]) (val :: *) where +class HasContextEntry (context :: [Type]) (val :: Type) where getContextEntry :: Context context -> val instance {-# OVERLAPPABLE #-} @@ -75,7 +87,7 @@ -- to have multiple values of the same type in your 'Context' and need to access -- them, we provide 'NamedContext'. You can think of it as sub-namespaces for -- 'Context's. -data NamedContext (name :: Symbol) (subContext :: [*]) +newtype NamedContext (name :: Symbol) (subContext :: [Type]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you diff --git a/src/Servant/Server/Internal/Delayed.hs b/src/Servant/Server/Internal/Delayed.hs --- a/src/Servant/Server/Internal/Delayed.hs +++ b/src/Servant/Server/Internal/Delayed.hs @@ -268,5 +268,5 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue , we cannot -do the more succint thing - just update the records we actually change. +do the more succinct thing - just update the records we actually change. -} diff --git a/src/Servant/Server/Internal/DelayedIO.hs b/src/Servant/Server/Internal/DelayedIO.hs --- a/src/Servant/Server/Internal/DelayedIO.hs +++ b/src/Servant/Server/Internal/DelayedIO.hs @@ -24,11 +24,11 @@ -- | Computations used in a 'Delayed' can depend on the -- incoming 'Request', may perform 'IO', and result in a --- 'RouteResult', meaning they can either suceed, fail +-- 'RouteResult', meaning they can either succeed, fail -- (with the possibility to recover), or fail fatally. -- newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } - deriving + deriving newtype ( Functor, Applicative, Monad , MonadIO, MonadReader Request , MonadThrow diff --git a/src/Servant/Server/Internal/ErrorFormatter.hs b/src/Servant/Server/Internal/ErrorFormatter.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ErrorFormatter.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.Internal.ErrorFormatter + ( ErrorFormatters(..) + , ErrorFormatter + , NotFoundErrorFormatter + + , DefaultErrorFormatters + , defaultErrorFormatters + + , MkContextWithErrorFormatter + , mkContextWithErrorFormatter + ) where + +import Data.Kind (Type) +import Data.Typeable +import Network.Wai.Internal (Request) +import qualified Data.ByteString.Lazy.Char8 as BSL8 + +import Servant.API + (Capture, ReqBody) +import Servant.Server.Internal.Context +import Servant.Server.Internal.ServerError + +-- | 'Context' that contains default error formatters. +type DefaultErrorFormatters = '[ErrorFormatters] + +-- | A collection of error formatters for different situations. +-- +-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax. +data ErrorFormatters = ErrorFormatters + { -- | Format error from parsing the request body. + bodyParserErrorFormatter :: ErrorFormatter + -- | Format error from parsing url parts or query parameters. + , urlParseErrorFormatter :: ErrorFormatter + -- | Format error from parsing request headers. + , headerParseErrorFormatter :: ErrorFormatter + -- | Format error for not found URLs. + , notFoundErrorFormatter :: NotFoundErrorFormatter + } + +-- | Default formatters will just return HTTP 400 status code with error +-- message as response body. +defaultErrorFormatters :: ErrorFormatters +defaultErrorFormatters = ErrorFormatters + { bodyParserErrorFormatter = err400Formatter + , urlParseErrorFormatter = err400Formatter + , headerParseErrorFormatter = err400Formatter + , notFoundErrorFormatter = const err404 + } + +-- | A custom formatter for errors produced by parsing combinators like +-- 'ReqBody' or 'Capture'. +-- +-- A 'TypeRep' argument described the concrete combinator that raised +-- the error, allowing formatter to customize the message for different +-- combinators. +-- +-- A full 'Request' is also passed so that the formatter can react to @Accept@ header, +-- for example. +type ErrorFormatter = TypeRep -> Request -> String -> ServerError + +-- | This formatter does not get neither 'TypeRep' nor error message. +type NotFoundErrorFormatter = Request -> ServerError + +type MkContextWithErrorFormatter (ctx :: [Type]) = ctx .++ DefaultErrorFormatters + +mkContextWithErrorFormatter :: forall (ctx :: [Type]). Context ctx -> Context (MkContextWithErrorFormatter ctx) +mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext) + +-- Internal + +err400Formatter :: ErrorFormatter +err400Formatter _ _ e = err400 { errBody = BSL8.pack e } + +-- These definitions suppress "unused import" warning. +-- The imorts are needed for Haddock to correctly link to them. +_RB :: Proxy ReqBody +_RB = Proxy +_C :: Proxy Capture +_C = Proxy +_CT :: Proxy Context +_CT = Proxy diff --git a/src/Servant/Server/Internal/Handler.hs b/src/Servant/Server/Internal/Handler.hs --- a/src/Servant/Server/Internal/Handler.hs +++ b/src/Servant/Server/Internal/Handler.hs @@ -1,37 +1,40 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module Servant.Server.Internal.Handler where -import Prelude () -import Prelude.Compat - import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Error.Class - (MonadError) + (MonadError, throwError) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except - (ExceptT, runExceptT) + (ExceptT(ExceptT), runExceptT) +import Data.String + (fromString) import GHC.Generics (Generic) import Servant.Server.Internal.ServerError - (ServerError) + (ServerError, errBody, err500) newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a } - deriving - ( Functor, Applicative, Monad, MonadIO, Generic + deriving stock (Generic) + deriving newtype + ( Functor, Applicative, Monad, MonadIO , MonadError ServerError , MonadThrow, MonadCatch, MonadMask ) +instance MonadFail Handler where + fail str = throwError err500 { errBody = fromString str } + instance MonadBase IO Handler where liftBase = Handler . liftBase @@ -46,3 +49,10 @@ runHandler :: Handler a -> IO (Either ServerError a) runHandler = runExceptT . runHandler' + +-- | Pattern synonym that matches directly on the inner 'IO' action. +-- +-- To lift 'IO' actions that don't carry a 'ServerError', use 'Control.Monad.IO.Class.liftIO' instead. +pattern MkHandler :: IO (Either ServerError a) -> Handler a +pattern MkHandler ioe = Handler (ExceptT ioe) +{-# COMPLETE MkHandler #-} diff --git a/src/Servant/Server/Internal/ResponseRender.hs b/src/Servant/Server/Internal/ResponseRender.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ResponseRender.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE EmptyCase #-} + +module Servant.Server.Internal.ResponseRender where + +import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.Typeable +import GHC.TypeLits +import qualified Data.ByteString.Lazy as BSL +import qualified Network.Wai as Wai +import Network.HTTP.Types (Status, hContentType) +import Data.SOP +import qualified Servant.Types.SourceT as S +import qualified Data.ByteString.Builder as BB +import qualified Data.Sequence as Seq + +import Servant.API.ContentTypes (AcceptHeader (..), AllMimeRender, MimeRender, Accept, allMimeRender, mimeRender, contentType) +import Servant.API.MultiVerb +import Servant.API.Status +import Servant.API.Stream (SourceIO) +import Servant.API.UVerb.Union +import Servant.Types.Internal.Response +import qualified Network.HTTP.Media as M +import Data.Foldable (toList) +import Data.Sequence ((<|)) + +class (Typeable a) => IsWaiBody a where + responseToWai :: InternalResponse a -> Wai.Response + +instance IsWaiBody BSL.ByteString where + responseToWai r = + Wai.responseLBS + (statusCode r) + (toList (headers r)) + (responseBody r) + +instance IsWaiBody () where + responseToWai r = + Wai.responseLBS + (statusCode r) + (toList (headers r)) + mempty + +instance IsWaiBody (SourceIO ByteString) where + responseToWai r = + Wai.responseStream + (statusCode r) + (toList (headers r)) + $ \output flush -> do + S.foreach + (const (pure ())) + (\chunk -> output (BB.byteString chunk) *> flush) + (responseBody r) + +data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (InternalResponse a) + +class ResponseListRender cs as where + responseListRender + :: AcceptHeader + -> Union (ResponseTypes as) + -> Maybe SomeResponse + responseListStatuses :: [Status] + +instance ResponseListRender cs '[] where + responseListRender _ x = case x of {} + responseListStatuses = [] + +class (IsWaiBody (ResponseBody a)) => ResponseRender cs a where + type ResponseStatus a :: Nat + type ResponseBody a :: Type + responseRender + :: AcceptHeader + -> ResponseType a + -> Maybe (InternalResponse (ResponseBody a)) + +instance + ( ResponseRender cs a, + ResponseListRender cs as, + KnownStatus (ResponseStatus a) + ) => + ResponseListRender cs (a ': as) + where + responseListRender acc (Z (I x)) = fmap SomeResponse (responseRender @cs @a acc x) + responseListRender acc (S x) = responseListRender @cs @as acc x + + responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as + +instance + ( AsHeaders xs (ResponseType r) a, + ServantHeaders hs xs, + ResponseRender cs r + ) => + ResponseRender cs (WithHeaders hs a r) + where + type ResponseStatus (WithHeaders hs a r) = ResponseStatus r + type ResponseBody (WithHeaders hs a r) = ResponseBody r + + responseRender acc x = addHeaders <$> responseRender @cs @r acc y + where + (hs, y) = toHeaders @xs x + addHeaders r = + r + { headers = headers r <> Seq.fromList (constructHeaders @hs hs) + } + +instance + ( KnownStatus s, + MimeRender ct a + ) => + ResponseRender cs (RespondAs (ct :: Type) s desc a) + where + type ResponseStatus (RespondAs ct s desc a) = s + type ResponseBody (RespondAs ct s desc a) = BSL.ByteString + + responseRender _ x = + pure . addContentType @ct $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = mimeRender (Proxy @ct) x, + headers = mempty + } + +instance (KnownStatus s) => ResponseRender cs (RespondAs '() s desc ()) where + type ResponseStatus (RespondAs '() s desc ()) = s + type ResponseBody (RespondAs '() s desc ()) = () + + responseRender _ _ = + pure $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = (), + headers = mempty + } + +instance + (Accept ct, KnownStatus s) + => ResponseRender cs (RespondStreaming s desc framing ct) + where + type ResponseStatus (RespondStreaming s desc framing ct) = s + type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + responseRender _ x = + pure . addContentType @ct $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = x, + headers = mempty + } + +instance + (AllMimeRender cs a, KnownStatus s) + => ResponseRender cs (Respond s desc a) where + type ResponseStatus (Respond s desc a) = s + type ResponseBody (Respond s desc a) = BSL.ByteString + + -- Note: here it seems like we are rendering for all possible content types, + -- only to choose the correct one afterwards. However, render results besides the + -- one picked by 'M.mapAcceptMedia' are not evaluated, and therefore nor are the + -- corresponding rendering functions. + responseRender (AcceptHeader acc) x = + M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) x)) acc + where + mkRenderOutput :: M.MediaType -> BSL.ByteString -> (M.MediaType, InternalResponse BSL.ByteString) + mkRenderOutput c body = + (c,) . addContentType' c $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = body, + headers = mempty + } + +addContentType :: forall ct a. (Accept ct) => InternalResponse a -> InternalResponse a +addContentType = addContentType' (contentType (Proxy @ct)) + +addContentType' :: M.MediaType -> InternalResponse a -> InternalResponse a +addContentType' c r = r {headers = (hContentType, M.renderHeader c) <| headers r} + +setEmptyBody :: SomeResponse -> SomeResponse +setEmptyBody (SomeResponse r) = SomeResponse (go r) + where + go :: InternalResponse a -> InternalResponse BSL.ByteString + go InternalResponse {..} = InternalResponse {responseBody = mempty, ..} + +someResponseToWai :: SomeResponse -> Wai.Response +someResponseToWai (SomeResponse r) = responseToWai r diff --git a/src/Servant/Server/Internal/RouteResult.hs b/src/Servant/Server/Internal/RouteResult.hs --- a/src/Servant/Server/Internal/RouteResult.hs +++ b/src/Servant/Server/Internal/RouteResult.hs @@ -28,11 +28,11 @@ deriving (Eq, Show, Read, Functor) instance Applicative RouteResult where - pure = return + pure = Route (<*>) = ap instance Monad RouteResult where - return = Route + return = pure Route a >>= f = f a Fail e >>= _ = Fail e FailFatal e >>= _ = FailFatal e @@ -41,14 +41,14 @@ deriving (Functor) instance MonadTrans RouteResultT where - lift = RouteResultT . liftM Route + lift = RouteResultT . fmap Route instance (Functor m, Monad m) => Applicative (RouteResultT m) where - pure = return + pure = RouteResultT . return . Route (<*>) = ap instance Monad m => Monad (RouteResultT m) where - return = RouteResultT . return . Route + return = pure m >>= k = RouteResultT $ do a <- runRouteResultT m case a of diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -4,25 +4,42 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where -import Prelude () -import Prelude.Compat - import Data.Function (on) +import Data.List + (nub) import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T +import Data.Typeable + (TypeRep) import Network.Wai (Response, pathInfo) -import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication +-- | Holds information about pieces of url that are captured as variables. +data CaptureHint = CaptureHint + { captureName :: Text + -- ^ Holds the name of the captured variable + , captureType :: TypeRep + -- ^ Holds the type of the captured variable + } + deriving (Show, Eq) + +toCaptureTag :: CaptureHint -> Text +toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint) + +toCaptureTags :: [CaptureHint] -> Text +toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">" + -- | Internal representation of a router. -- -- The first argument describes an environment type that is @@ -35,12 +52,23 @@ -- ^ the map contains routers for subpaths (first path component used -- for lookup and removed afterwards), the list contains handlers -- for the empty path, to be tried in order - | CaptureRouter (Router' (Text, env) a) + | CaptureRouter [CaptureHint] (Router' (Text, env) a) -- ^ first path component is passed to the child router in its - -- environment and removed afterwards - | CaptureAllRouter (Router' ([Text], env) a) + -- environment and removed afterwards. + -- The first argument is a list of hints for all variables that can be + -- captured by the router. The fact that it is a list is counter-intuitive, + -- because the 'Capture' combinator only allows to capture a single varible, + -- with a single name and a single type. However, the 'choice' smart + -- constructor may merge two 'Capture' combinators with different hints, thus + -- forcing the type to be '[CaptureHint]'. + -- Because 'CaptureRouter' is built from a 'Capture' combinator, the list of + -- hints should always be non-empty. + | CaptureAllRouter [CaptureHint] (Router' ([Text], env) a) -- ^ all path components are passed to the child router in its -- environment and are removed afterwards + -- The first argument is a hint for the list of variables that can be + -- captured by the router. Note that the 'captureType' field of the hint + -- should always be '[a]' for some 'a'. | RawRouter (env -> a) -- ^ to be used for routes we do not know anything about | Choice (Router' env a) (Router' env a) @@ -68,8 +96,8 @@ choice :: Router' env a -> Router' env a -> Router' env a choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) -choice (CaptureRouter router1) (CaptureRouter router2) = - CaptureRouter (choice router1 router2) +choice (CaptureRouter hints1 router1) (CaptureRouter hints2 router2) = + CaptureRouter (nub $ hints1 ++ hints2) (choice router1 router2) choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 @@ -83,7 +111,11 @@ -- data RouterStructure = StaticRouterStructure (Map Text RouterStructure) Int - | CaptureRouterStructure RouterStructure + | CaptureRouterStructure [CaptureHint] RouterStructure + -- ^ The first argument holds information about variables + -- that are captured by the router. There may be several hints + -- if several routers have been aggregated by the 'choice' + -- smart constructor. | RawRouterStructure | ChoiceStructure RouterStructure RouterStructure deriving (Eq, Show) @@ -97,11 +129,11 @@ routerStructure :: Router' env a -> RouterStructure routerStructure (StaticRouter m ls) = StaticRouterStructure (fmap routerStructure m) (length ls) -routerStructure (CaptureRouter router) = - CaptureRouterStructure $ +routerStructure (CaptureRouter hints router) = + CaptureRouterStructure hints $ routerStructure router -routerStructure (CaptureAllRouter router) = - CaptureRouterStructure $ +routerStructure (CaptureAllRouter hints router) = + CaptureRouterStructure hints $ routerStructure router routerStructure (RawRouter _) = RawRouterStructure @@ -113,8 +145,8 @@ -- | Compare the structure of two routers. -- sameStructure :: Router' env a -> Router' env b -> Bool -sameStructure r1 r2 = - routerStructure r1 == routerStructure r2 +sameStructure router1 router2 = + routerStructure router1 == routerStructure router2 -- | Provide a textual representation of the -- structure of a router. @@ -125,7 +157,8 @@ where mkRouterLayout :: Bool -> RouterStructure -> [Text] mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n - mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c (CaptureRouterStructure hints r) = + mkSubTree c (toCaptureTags hints) (mkRouterLayout False r) mkRouterLayout c RawRouterStructure = if c then ["├─ "] else ["└─ "] mkRouterLayout c (ChoiceStructure r1 r2) = @@ -153,52 +186,55 @@ tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application. -runRouter :: Router () -> RoutingApplication -runRouter r = runRouterEnv r () +runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication +runRouter fmt r = runRouterEnv fmt r () -runRouterEnv :: Router env -> env -> RoutingApplication -runRouterEnv router env request respond = +runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication +runRouterEnv fmt router env request respond = case router of StaticRouter table ls -> case pathInfo request of - [] -> runChoice ls env request respond + [] -> runChoice fmt ls env request respond -- This case is to handle trailing slashes. - [""] -> runChoice ls env request respond + [""] -> runChoice fmt ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest } - in runRouterEnv router' env request' respond - _ -> respond $ Fail err404 - CaptureRouter router' -> + in runRouterEnv fmt router' env request' respond + _ -> respond $ Fail $ fmt request + CaptureRouter _ router' -> case pathInfo request of - [] -> respond $ Fail err404 + [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes. - [""] -> respond $ Fail err404 + [""] -> respond $ Fail $ fmt request first : rest -> let request' = request { pathInfo = rest } - in runRouterEnv router' (first, env) request' respond - CaptureAllRouter router' -> - let segments = pathInfo request + in runRouterEnv fmt router' (first, env) request' respond + CaptureAllRouter _ router' -> + let segments = case pathInfo request of + -- this case is to handle trailing slashes. + ("":xs) -> xs + xs -> xs request' = request { pathInfo = [] } - in runRouterEnv router' (segments, env) request' respond + in runRouterEnv fmt router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> - runChoice [runRouterEnv r1, runRouterEnv r2] env request respond + runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. -- -runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication -runChoice ls = +runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication +runChoice fmt ls = case ls of - [] -> \ _ _ respond -> respond (Fail err404) + [] -> \ _ request respond -> respond (Fail $ fmt request) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of - Fail _ -> runChoice rs env request $ \ response2 -> + Fail _ -> runChoice fmt rs env request $ \ response2 -> respond $ highestPri response1 response2 _ -> respond response1 where diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -2,8 +2,6 @@ import Network.Wai (Application, Request, Response, ResponseReceived) -import Prelude () -import Prelude.Compat import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError diff --git a/src/Servant/Server/Internal/ServerError.hs b/src/Servant/Server/Internal/ServerError.hs --- a/src/Servant/Server/Internal/ServerError.hs +++ b/src/Servant/Server/Internal/ServerError.hs @@ -187,7 +187,7 @@ -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" } -- err404 :: ServerError err404 = ServerError { errHTTPCode = 404 @@ -388,6 +388,20 @@ err422 :: ServerError err422 = ServerError { errHTTPCode = 422 , errReasonPhrase = "Unprocessable Entity" + , errBody = "" + , errHeaders = [] + } + +-- | 'err429' Too Many Requests +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err429 { errBody = "You have sent too many requests in a short period of time." } +-- +err429 :: ServerError +err429 = ServerError { errHTTPCode = 429 + , errReasonPhrase = "Too Many Requests" , errBody = "" , errHeaders = [] } diff --git a/src/Servant/Server/UVerb.hs b/src/Servant/Server/UVerb.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/UVerb.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Servant.Server.UVerb + ( respond, + IsServerResource, + ) +where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BSL +import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) +import Data.SOP (I (I)) +import Data.SOP.Constraint (All, And) +import Network.HTTP.Types (Status, HeaderName, hContentType) +import Network.Wai (responseLBS, Request) +import Servant.API (ReflectMethod, reflectMethod) +import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) +import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..)) +import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf) +import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) + + +-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, +-- and will construct a union value in an 'Applicative' (eg. 'Server'). +respond :: + forall (x :: Type) (xs :: [Type]) (f :: Type -> Type). + (Applicative f, HasStatus x, IsMember x xs) => + x -> + f (Union xs) +respond = pure . inject . I + +class IsServerResource (cts :: [Type]) a where + resourceResponse :: Request -> Proxy cts -> a -> Maybe (BSL.ByteString, BSL.ByteString) + resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)] + +instance {-# OVERLAPPABLE #-} AllCTRender cts a + => IsServerResource cts a where + resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res + resourceHeaders _ _ = [] + +instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a)) + => IsServerResource cts (Headers h a) where + resourceResponse request p res = resourceResponse request p (getResponse res) + resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res) + +instance {-# OVERLAPPING #-} IsServerResource cts a + => IsServerResource cts (WithStatus n a) where + resourceResponse request p (WithStatus x) = resourceResponse request p x + resourceHeaders cts (WithStatus x) = resourceHeaders cts x + +encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a) + => Request -> Proxy cts -> a + -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)]) +encodeResource request cts res = (statusOf (Proxy @a), + resourceResponse request cts res, + resourceHeaders cts res) + +type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus + +instance + ( ReflectMethod method, + AllMime contentTypes, + All (IsServerResourceWithStatus contentTypes) as, + Unique (Statuses as) -- for consistency with servant-swagger (server would work fine + -- 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. + ) => + HasServer (UVerb method contentTypes as) context + where + type ServerT (UVerb method contentTypes as) m = m (Union as) + + hoistServerWithContext _ _ nt s = nt s + + route :: + forall env. + Proxy (UVerb method contentTypes as) -> + Context context -> + Delayed env (Server (UVerb method contentTypes as)) -> + Router env + route _proxy _ctx action = leafRouter route' + where + method = reflectMethod (Proxy @method) + route' env request cont = do + let action' :: Delayed env (Handler (Union as)) + action' = + action + `addMethodCheck` methodCheck method request + `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request) + + runAction action' env request cont $ \(output :: Union as) -> do + let cts = Proxy @contentTypes + pickResource :: Union as -> (Status, Maybe (BSL.ByteString, BSL.ByteString), [(HeaderName, B.ByteString)]) + pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) + case pickResource output of + (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + (status, Just (contentT, body), headers) -> + let bdy = if allowedMethodHead method request then "" else body + in Route $ responseLBS status ((hContentType, BSL.toStrict contentT) : headers) bdy diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs --- a/test/Servant/Server/ErrorSpec.hs +++ b/test/Servant/Server/ErrorSpec.hs @@ -11,9 +11,7 @@ import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as BCL -import Data.Monoid - ((<>)) +import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Proxy import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, methodPost, @@ -31,6 +29,7 @@ prioErrorsSpec errorRetrySpec errorChoiceSpec + customFormattersSpec -- * Auth machinery (reused throughout) @@ -295,11 +294,66 @@ -- }}} ------------------------------------------------------------------------------ +-- * Custom errors {{{ + +customFormatter :: ErrorFormatter +customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> BSL8.pack err } + +customFormatters :: ErrorFormatters +customFormatters = defaultErrorFormatters + { bodyParserErrorFormatter = customFormatter + , urlParseErrorFormatter = customFormatter + , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" } + } + +type CustomFormatterAPI + = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String + :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String + :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String + +customFormatterAPI :: Proxy CustomFormatterAPI +customFormatterAPI = Proxy + +customFormatterServer :: Server CustomFormatterAPI +customFormatterServer = (\_ -> return "query") + :<|> (\_ -> return "capture") + :<|> (\_ -> return "body") + +customFormattersSpec :: Spec +customFormattersSpec = describe "Custom errors from combinators" + $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do + + let startsWithCustom = ResponseMatcher + { matchStatus = 400 + , matchHeaders = [] + , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BSL8.isPrefixOf` body + then Nothing + else Just $ show body <> " does not start with \"CUSTOM!\"" + } + + it "formats query parse error" $ do + request methodGet "query?param=false" [] "" + `shouldRespondWith` startsWithCustom + + it "formats query parse error with missing param" $ do + request methodGet "query" [] "" + `shouldRespondWith` startsWithCustom + + it "formats capture parse error" $ do + request methodGet "capture/42" [] "" + `shouldRespondWith` startsWithCustom + + it "formats body parse error" $ do + request methodPost "body" [(hContentType, "application/json")] "foo" + `shouldRespondWith` startsWithCustom + +-- }}} +------------------------------------------------------------------------------ -- * Instances {{{ instance MimeUnrender PlainText Int where - mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x) + mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BSL8.unpack x) instance MimeRender PlainText Int where - mimeRender _ = BCL.pack . show + mimeRender _ = BSL8.pack . show -- }}} diff --git a/test/Servant/Server/Internal/ContextSpec.hs b/test/Servant/Server/Internal/ContextSpec.hs --- a/test/Servant/Server/Internal/ContextSpec.hs +++ b/test/Servant/Server/Internal/ContextSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy 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/Server/RouterSpec.hs b/test/Servant/Server/RouterSpec.hs --- a/test/Servant/Server/RouterSpec.hs +++ b/test/Servant/Server/RouterSpec.hs @@ -9,7 +9,9 @@ import Data.Proxy (Proxy (..)) import Data.Text - (unpack) + (Text, unpack) +import Data.Typeable + (typeRep) import Network.HTTP.Types (Status (..)) import Network.Wai @@ -27,12 +29,13 @@ spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec + serverLayoutSpec routerSpec :: Spec routerSpec = do describe "tweakResponse" $ do let app' :: Application - app' = toApplication $ runRouter router' + app' = toApplication $ runRouter (const err404) router' router', router :: Router () router' = tweakResponse (fmap twk) router @@ -48,10 +51,10 @@ describe "runRouter" $ do let toApp :: Router () -> Application - toApp = toApplication . runRouter + toApp = toApplication . runRouter (const err404) cap :: Router () - cap = CaptureRouter $ + cap = CaptureRouter [hint] $ let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400) in leafRouter $ \env req res -> @@ -59,6 +62,9 @@ . const $ Route success + hint :: CaptureHint + hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ()) + router :: Router () router = leafRouter (\_ _ res -> res $ Route success) `Choice` cap @@ -98,12 +104,30 @@ it "properly handles mixing static paths at different levels" $ do level `shouldHaveSameStructureAs` levelRef +serverLayoutSpec :: Spec +serverLayoutSpec = + describe "serverLayout" $ do + it "correctly represents the example API" $ do + exampleLayout `shouldHaveLayout` expectedExampleLayout + it "aggregates capture hints when different" $ do + captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes + it "nubs capture hints when equal" $ do + captureSameType `shouldHaveLayout` expectedCaptureSameType + it "properly displays CaptureAll hints" $ do + captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout + shouldHaveSameStructureAs :: (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation shouldHaveSameStructureAs p1 p2 = unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) +shouldHaveLayout :: + (HasServer api '[]) => Proxy api -> Text -> Expectation +shouldHaveLayout p l = + unless (routerLayout (makeTrivialRouter p) == l) $ + expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p)) + makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () makeTrivialRouter p = route p EmptyContext (emptyDelayed (FailFatal err501)) @@ -144,12 +168,12 @@ -- structure: type Dynamic = - "a" :> Capture "foo" Int :> "b" :> End - :<|> "a" :> Capture "bar" Bool :> "c" :> End - :<|> "a" :> Capture "baz" Char :> "d" :> End + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "foo" Int :> "c" :> End + :<|> "a" :> Capture "foo" Int :> "d" :> End type DynamicRef = - "a" :> Capture "anything" () :> + "a" :> Capture "foo" Int :> ("b" :> End :<|> "c" :> End :<|> "d" :> End) dynamic :: Proxy Dynamic @@ -339,3 +363,100 @@ levelRef :: Proxy LevelRef levelRef = Proxy + +-- The example API for the 'layout' function. +-- Should get factorized by the 'choice' smart constructor. +type ExampleLayout = + "a" :> "d" :> Get '[JSON] NoContent + :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool + :<|> "c" :> Put '[JSON] Bool + :<|> "a" :> "e" :> Get '[JSON] Int + :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool + :<|> Raw + +exampleLayout :: Proxy ExampleLayout +exampleLayout = Proxy + +-- The expected representation of the example API layout +-- +expectedExampleLayout :: Text +expectedExampleLayout = + "/\n\ + \├─ a/\n\ + \│ ├─ d/\n\ + \│ │ └─•\n\ + \│ └─ e/\n\ + \│ └─•\n\ + \├─ b/\n\ + \│ └─ /\n\ + \│ ├─•\n\ + \│ ┆\n\ + \│ └─•\n\ + \├─ c/\n\ + \│ └─•\n\ + \┆\n\ + \└─ \n" + +-- A capture API with all capture types being the same +-- +type CaptureSameType = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "foo" Int :> "c" :> End + :<|> "a" :> Capture "foo" Int :> "d" :> End + +captureSameType :: Proxy CaptureSameType +captureSameType = Proxy + +-- The expected representation of the CaptureSameType API layout. +-- +expectedCaptureSameType :: Text +expectedCaptureSameType = + "/\n\ + \└─ a/\n\ + \ └─ /\n\ + \ ├─ b/\n\ + \ │ └─•\n\ + \ ├─ c/\n\ + \ │ └─•\n\ + \ └─ d/\n\ + \ └─•\n" + +-- A capture API capturing different types +-- +type CaptureDifferentTypes = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "bar" Bool :> "c" :> End + :<|> "a" :> Capture "baz" Char :> "d" :> End + +captureDifferentTypes :: Proxy CaptureDifferentTypes +captureDifferentTypes = Proxy + +-- The expected representation of the CaptureDifferentTypes API layout. +-- +expectedCaptureDifferentTypes :: Text +expectedCaptureDifferentTypes = + "/\n\ + \└─ a/\n\ + \ └─ /\n\ + \ ├─ b/\n\ + \ │ └─•\n\ + \ ├─ c/\n\ + \ │ └─•\n\ + \ └─ d/\n\ + \ └─•\n" + +-- An API with a CaptureAll part + +type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End + +captureAllLayout :: Proxy CaptureAllLayout +captureAllLayout = Proxy + +-- The expected representation of the CaptureAllLayout API. +-- +expectedCaptureAllLayout :: Text +expectedCaptureAllLayout = + "/\n\ + \└─ a/\n\ + \ └─ /\n\ + \ └─•\n" diff --git a/test/Servant/Server/StreamingSpec.hs b/test/Servant/Server/StreamingSpec.hs --- a/test/Servant/Server/StreamingSpec.hs +++ b/test/Servant/Server/StreamingSpec.hs @@ -81,10 +81,10 @@ executeRequest :: Application -> Request -> IO Response executeRequest app request = do responseMVar <- newEmptyMVar - let respond response = do + let respondToRequest response = do putMVar responseMVar response return ResponseReceived - ResponseReceived <- app request respond + ResponseReceived <- app request respondToRequest takeMVar responseMVar timeout :: IO a -> IO a diff --git a/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/test/Servant/Server/UsingContextSpec/TestCombinators.hs --- a/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -20,6 +20,7 @@ import GHC.TypeLits import Servant +import Data.Kind (Type) data ExtractFromContext @@ -32,12 +33,12 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s route Proxy context delayed = - route subProxy context (fmap inject delayed) + route subProxy context (fmap injectContext delayed) where subProxy :: Proxy subApi subProxy = Proxy - inject f = f (getContextEntry context) + injectContext f = f (getContextEntry context) data InjectIntoContext @@ -58,7 +59,7 @@ newContext = ("injected" :: String) :. context -data NamedContextWithBirdface (name :: Symbol) (subContext :: [*]) +data NamedContextWithBirdface (name :: Symbol) (subContext :: [Type]) instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => HasServer (NamedContextWithBirdface name subContext :> subApi) context where diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -16,12 +16,18 @@ import Prelude.Compat import Control.Monad - (forM_, unless, when) + (forM_, join, unless, when) +import Control.Monad.Reader (runReaderT, ask) import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Aeson (FromJSON, ToJSON, decode', encode) +import Data.Acquire + (Acquire, mkAcquire) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) @@ -31,8 +37,6 @@ (Proxy (Proxy)) import Data.String (fromString) -import Data.String.Conversions - (cs) import qualified Data.Text as T import GHC.Generics (Generic) @@ -49,22 +53,31 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, Header, Headers, HttpVersion, + Delete, Description, EmptyAPI, Fragment, Get, HasStatus (StatusOf), + Header, Header', Headers, HttpVersion, IsSecure (..), JSON, Lenient, + NoContent (..), NoContentVerb, NoFraming, OctetStream, Optional, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RawM, + DeepQuery, 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, Verb, addHeader) + QueryFlag, QueryParam, QueryParams, QueryString, Raw, + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, + UVerb, Union, Verb, WithStatus (..), addHeader, addHeader') +import Servant.API.QueryString (FromDeepQuery(..)) import Servant.Server - (Context ((:.), EmptyContext), Handler, Server, Tagged (..), - emptyServer, err401, err403, err404, serve, serveWithContext) + (Context ((:.), EmptyContext), Handler, Server, ServerT, Tagged (..), + emptyServer, err401, err403, err404, hoistServer, respond, serve, + serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Test.Hspec.Wai - (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, + (get, matchHeaders, matchStatus, shouldRespondWith, with, (<:>)) import qualified Test.Hspec.Wai as THW +import Text.Read (readMaybe) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) @@ -79,22 +92,29 @@ -- This declaration simply checks that all instances are in place. _ = serveWithContext comprehensiveAPI comprehensiveApiContext -comprehensiveApiContext :: Context '[NamedContext "foo" '[]] -comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext +comprehensiveApiContext :: Context '[NamedContext "foo" '[], Acquire Int] +comprehensiveApiContext = + NamedContext EmptyContext :. + mkAcquire (pure 10) (\_ -> pure ()) :. + EmptyContext -- * Specs spec :: Spec spec = do verbSpec + uverbSpec captureSpec captureAllSpec queryParamSpec + fragmentSpec reqBodySpec headerSpec rawSpec + rawMSpec alternativeSpec responseHeadersSpec + uverbResponseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -108,6 +128,7 @@ :<|> "noContent" :> NoContentVerb method :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "headerD" :> Verb method status '[JSON] (Headers '[Header' '[Description "desc", Optional, Strict] "H" Int] Person) :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) @@ -120,6 +141,7 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B") :<|> return (S.source ["bytestring"]) @@ -151,9 +173,8 @@ response <- THW.request method "/" [] "" liftIO $ simpleBody response `shouldBe` "" - it "throws 405 on wrong method " $ do - THW.request (wrongMethod method) "/" [] "" - `shouldRespondWith` 405 + it "throws 405 on wrong method " $ THW.request (wrongMethod method) "/" [] "" + `shouldRespondWith` 405 it "returns headers" $ do response1 <- THW.request method "/header" [] "" @@ -164,13 +185,16 @@ liftIO $ statusCode (simpleStatus response2) `shouldBe` status liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + response3 <- THW.request method "/headerD" [] "" + liftIO $ statusCode (simpleStatus response3) `shouldBe` status + liftIO $ simpleHeaders response3 `shouldContain` [("H", "5")] + it "handles trailing '/' gracefully" $ do response <- THW.request method "/headerNC/" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status - it "returns 406 if the Accept header is not supported" $ do - THW.request method "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 + it "returns 406 if the Accept header is not supported" $ THW.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 406 it "responds if the Accept header is supported" $ do response <- THW.request method "" @@ -229,103 +253,140 @@ getEyes _ = throwError err404 captureSpec :: Spec -captureSpec = do - describe "Servant.API.Capture" $ do - with (return (serve captureApi captureServer)) $ do +captureSpec = describe "Servant.API.Capture" $ do + with (return (serve captureApi captureServer)) $ do - it "can capture parts of the 'pathInfo'" $ do - response <- get "/2" - liftIO $ decode' (simpleBody response) `shouldBe` Just tweety + it "can capture parts of the 'pathInfo'" $ do + response <- get "/2" + liftIO $ decode' (simpleBody response) `shouldBe` Just tweety - it "returns 400 if the decoding fails" $ do - get "/notAnInt" `shouldRespondWith` 400 + it "returns 400 if the decoding fails" $ get "/notAnInt" `shouldRespondWith` 400 - it "returns an animal if eyes or ears are 2" $ do - get "/ears/2" `shouldRespondWith` 200 - get "/eyes/2" `shouldRespondWith` 200 + it "returns an animal if eyes or ears are 2" $ do + get "/ears/2" `shouldRespondWith` 200 + get "/eyes/2" `shouldRespondWith` 200 - it "returns a weird animal on Lenient Capture" $ do - response <- get "/ears/bla" - liftIO $ decode' (simpleBody response) `shouldBe` Just chimera + it "returns a weird animal on Lenient Capture" $ do + response <- get "/ears/bla" + liftIO $ decode' (simpleBody response) `shouldBe` Just chimera - it "returns 400 if parsing integer fails on Strict Capture" $ do - get "/eyes/bla" `shouldRespondWith` 400 + it "returns 400 if parsing integer fails on Strict Capture" $ get "/eyes/bla" `shouldRespondWith` 400 - with (return (serve - (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do - it "strips the captured path snippet from pathInfo" $ do - get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) + with (return (serve + (Proxy :: Proxy (Capture "captured" String :> Raw)) + (\ "captured" -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (BSL8.pack $ show $ pathInfo request_)))) + $ it "strips the captured path snippet from pathInfo" $ get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) -- }}} ------------------------------------------------------------------------------ -- * captureAllSpec {{{ ------------------------------------------------------------------------------ -type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal +type CaptureAllApi = "legs" :> CaptureAll "legs" Integer :> Get '[JSON] Animal + :<|> "arms" :> CaptureAll "arms" String :> Get '[JSON] [String] captureAllApi :: Proxy CaptureAllApi captureAllApi = Proxy -captureAllServer :: [Integer] -> Handler Animal -captureAllServer legs = case sum legs of - 4 -> return jerry - 2 -> return tweety - 0 -> return beholder - _ -> throwError err404 +captureAllServer :: Server CaptureAllApi +captureAllServer = handleLegs :<|> return + where + handleLegs [] = return beholder + handleLegs legs = case sum legs of + 4 -> return jerry + 2 -> return tweety + _ -> throwError err404 +type RootedCaptureAllApi = CaptureAll "xs" String :> Get '[JSON] [String] + captureAllSpec :: Spec captureAllSpec = do + let getStringList = decode' @[String] . simpleBody + describe "Servant.API.CaptureAll" $ do with (return (serve captureAllApi captureAllServer)) $ do it "can capture a single element of the 'pathInfo'" $ do - response <- get "/2" + response <- get "/legs/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety it "can capture multiple elements of the 'pathInfo'" $ do - response <- get "/2/2" + response <- get "/legs/2/2" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture arbitrarily many elements of the 'pathInfo'" $ do - response <- get "/1/1/0/1/0/1" + response <- get "/legs/1/1/0/1/0/1" liftIO $ decode' (simpleBody response) `shouldBe` Just jerry it "can capture when there are no elements in 'pathInfo'" $ do - response <- get "/" + response <- get "/legs/" liftIO $ decode' (simpleBody response) `shouldBe` Just beholder - it "returns 400 if the decoding fails" $ do - get "/notAnInt" `shouldRespondWith` 400 + it "returns 400 if the decoding fails" $ get "/legs/notAnInt" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, regardless of which element" $ do - get "/1/0/0/notAnInt/3/" `shouldRespondWith` 400 + it "returns 400 if the decoding fails, regardless of which element" $ get "/legs/1/0/0/notAnInt/3/" `shouldRespondWith` 400 - it "returns 400 if the decoding fails, even when it's multiple elements" $ do - get "/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + it "returns 400 if the decoding fails, even when it's multiple elements" $ get "/legs/1/0/0/notAnInt/3/orange/" `shouldRespondWith` 400 + it "can capture single String" $ do + response <- get "/arms/jerry" + liftIO $ getStringList response `shouldBe` Just ["jerry"] + + it "can capture when there are no elements in 'pathinfo'" $ do + response <- get "/arms/" + liftIO $ getStringList response `shouldBe` Just [] + + it "can capture empty string from captureall" $ do + response <- get "/arms//" + liftIO $ getStringList response `shouldBe` Just [""] + + with (return (serve (Proxy :: Proxy RootedCaptureAllApi) return)) $ do + it "can capture empty rooted capture all" $ do + response <- get "/" + liftIO $ getStringList response `shouldBe` Just [] + + it "can capture empty string from rooted capture all" $ do + response <- get "//" + liftIO $ getStringList response `shouldBe` Just [""] + with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do - it "consumes everything from pathInfo" $ do - get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) + (\ _captured -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (BSL8.pack $ show $ pathInfo request_)))) + $ it "consumes everything from pathInfo" + $ get "/captured/foo/bar/baz" `shouldRespondWith` fromString (show ([] :: [Int])) -- }}} ------------------------------------------------------------------------------ -- * queryParamSpec {{{ ------------------------------------------------------------------------------ +data Filter = Filter + { ageFilter :: Integer + , nameFilter :: String + } + deriving Show + +instance FromDeepQuery Filter where + fromDeepQuery params = do + let maybeToRight l = maybe (Left l) Right + age' <- maybeToRight "missing age" $ readMaybe . T.unpack =<< join (lookup ["age"] params) + name' <- maybeToRight "missing name" $ join $ lookup ["name"] params + return $ Filter age' (T.unpack name') + + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person :<|> "param" :> QueryParam "age" Integer :> Get '[JSON] Person :<|> "multiparam" :> QueryParams "ages" Integer :> Get '[JSON] Person + :<|> "raw-query-string" :> QueryString :> Get '[JSON] Person + :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person queryParamApi :: Proxy QueryParamApi queryParamApi = Proxy qpServer :: Server QueryParamApi -qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges +qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAges :<|> qpRaw :<|> qpDeep where qpNames (_:name2:_) = return alice { name = name2 } qpNames _ = return alice @@ -338,6 +399,15 @@ qpAges ages = return alice{ age = sum ages} + qpRaw q = return alice { name = maybe mempty BS8.unpack $ join (lookup "name" q) + , age = fromMaybe 0 (readMaybe . BS8.unpack =<< join (lookup "age" q)) + } + + qpDeep filter' = + return alice { name = nameFilter filter' + , age = ageFilter filter' + } + queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice @@ -409,11 +479,27 @@ { name = "Alice" } + it "allows retrieving a full query string" $ + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=32&name=john" ["raw-query-string"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { name = "john" + , age = 32 + } + + it "allows retrieving a query string deep object" $ + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?filter[age]=32&filter[name]=john" ["deep-query"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { name = "john" + , age = 32 + } + describe "Uses queryString instead of rawQueryString" $ do -- test query parameters rewriter let queryRewriter :: Middleware queryRewriter app req = app req - { queryString = fmap rewrite $ queryString req + { queryString = rewrite <$> queryString req } where rewrite :: QueryItem -> QueryItem @@ -461,6 +547,35 @@ -- }}} ------------------------------------------------------------------------------ +-- * 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" $ it "ignores fragment even if it is present in query" $ flip runSession (serve fragmentApi fragServer) $ do + response1 <- mkRequest "#Alice" ["name"] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + +-- }}} +------------------------------------------------------------------------------ -- * reqBodySpec {{{ ------------------------------------------------------------------------------ type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person @@ -483,12 +598,10 @@ response <- mkReq methodPost "" (encode alice) liftIO $ decode' (simpleBody response) `shouldBe` Just alice - it "rejects invalid request bodies with status 400" $ do - mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 + it "rejects invalid request bodies with status 400" $ mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 - it "responds with 415 if the request body media type is unsupported" $ do - THW.request methodPost "/" - [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 + it "responds with 415 if the request body media type is unsupported" $ THW.request methodPost "/" + [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------ @@ -544,31 +657,59 @@ rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application -rawApplication f = Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] - (cs $ show $ f request_) +rawApplication f = Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] + (BSL8.pack $ show $ f request_) rawSpec :: Spec -rawSpec = do - describe "Servant.API.Raw" $ do - it "runs applications" $ do - flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do - response <- Network.Wai.Test.request defaultRequest{ - pathInfo = ["foo"] - } - liftIO $ do - simpleBody response `shouldBe` "42" +rawSpec = describe "Servant.API.Raw" $ do + it "runs applications" $ flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ simpleBody response `shouldBe` "42" - it "gets the pathInfo modified" $ do - flip runSession (serve rawApi (rawApplication pathInfo)) $ do - response <- Network.Wai.Test.request defaultRequest{ - pathInfo = ["foo", "bar"] - } - liftIO $ do - simpleBody response `shouldBe` cs (show ["bar" :: String]) + it "gets the pathInfo modified" $ flip runSession (serve rawApi (rawApplication pathInfo)) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo", "bar"] + } + liftIO $ simpleBody response `shouldBe` BSL8.pack (show ["bar" :: String]) -- }}} ------------------------------------------------------------------------------ +-- * rawMSpec {{{ +------------------------------------------------------------------------------ + +type RawMApi = "foo" :> RawM + +rawMApi :: Proxy RawMApi +rawMApi = Proxy + +rawMServer :: (MonadIO m, Show a) => (Request -> m a) -> ServerT RawMApi m +rawMServer f req resp = liftIO . resp . responseLBS ok200 [] . BSL8.pack . show =<< f req + +rawMSpec :: Spec +rawMSpec = describe "Servant.API.RawM" $ do + it "gives access to monadic context" $ flip runSession (serve rawMApi + (hoistServer rawMApi (`runReaderT` (42 :: Integer)) (rawMServer (const ask)))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ simpleBody response `shouldBe` "42" + + it "lets users throw servant errors" $ flip runSession (serve rawMApi (rawMServer (const $ throwError err404 >> pure (42 :: Integer)))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo"] + } + liftIO $ statusCode (simpleStatus response) `shouldBe` 404 + + it "gets the pathInfo modified" $ flip runSession (serve rawMApi (rawMServer (pure . pathInfo))) $ do + response <- Network.Wai.Test.request defaultRequest{ + pathInfo = ["foo", "bar"] + } + liftIO $ simpleBody response `shouldBe` BSL8.pack (show ["bar" :: String]) +-- }}} +------------------------------------------------------------------------------ -- * alternativeSpec {{{ ------------------------------------------------------------------------------ type AlternativeApi = @@ -592,25 +733,19 @@ :<|> return NoContent alternativeSpec :: Spec -alternativeSpec = do - describe "Servant.API.Alternative" $ do - with (return $ serve alternativeApi alternativeServer) $ do +alternativeSpec = describe "Servant.API.Alternative" $ with (return $ serve alternativeApi alternativeServer) $ do - it "unions endpoints" $ do - response <- get "/foo" - liftIO $ do - decode' (simpleBody response) `shouldBe` - Just alice - response_ <- get "/bar" - liftIO $ do - decode' (simpleBody response_) `shouldBe` - Just jerry + it "unions endpoints" $ do + response <- get "/foo" + liftIO $ decode' (simpleBody response) `shouldBe` + Just alice + response_ <- get "/bar" + liftIO $ decode' (simpleBody response_) `shouldBe` + Just jerry - it "checks all endpoints before returning 415" $ do - get "/foo" `shouldRespondWith` 200 + it "checks all endpoints before returning 415" $ get "/foo" `shouldRespondWith` 200 - it "returns 404 if the path does not exist" $ do - get "/nonexistent" `shouldRespondWith` 404 + it "returns 404 if the path does not exist" $ get "/nonexistent" `shouldRespondWith` 404 -- }}} ------------------------------------------------------------------------------ -- * responseHeaderSpec {{{ @@ -628,30 +763,51 @@ responseHeadersSpec :: Spec -responseHeadersSpec = describe "ResponseHeaders" $ do - with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do +responseHeadersSpec = describe "ResponseHeaders" $ with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [methodGet, methodPost, methodPut, methodPatch] + let methods = [methodGet, methodPost, methodPut, methodPatch] - it "includes the headers in the response" $ - forM_ methods $ \method -> - THW.request method "/" [] "" - `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] - , matchStatus = 200 - } + it "includes the headers in the response" $ + forM_ methods $ \method -> + THW.request method "/" [] "" + `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] + , matchStatus = 200 + } - it "responds with not found for non-existent endpoints" $ - forM_ methods $ \method -> - THW.request method "blahblah" [] "" - `shouldRespondWith` 404 + it "responds with not found for non-existent endpoints" $ + forM_ methods $ \method -> + THW.request method "blahblah" [] "" + `shouldRespondWith` 404 - it "returns 406 if the Accept header is not supported" $ - forM_ methods $ \method -> - THW.request method "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 + it "returns 406 if the Accept header is not supported" $ + forM_ methods $ \method -> + THW.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 406 -- }}} ------------------------------------------------------------------------------ +-- * uverbResponseHeaderSpec {{{ +------------------------------------------------------------------------------ +type UVerbHeaderResponse = '[ + WithStatus 200 (Headers '[Header "H1" Int] String), + WithStatus 404 String ] + +type UVerbResponseHeadersApi = + Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse + +uverbResponseHeadersServer :: Server UVerbResponseHeadersApi +uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String) +uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String) + +uverbResponseHeadersSpec :: Spec +uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ it "includes the headers in the response" $ + THW.request methodGet "/true" [] "" + `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"] + , matchStatus = 200 + } + +-- }}} +------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ type MiscCombinatorsAPI @@ -706,7 +862,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -717,26 +873,22 @@ in basicHandler :. EmptyContext basicAuthSpec :: Spec -basicAuthSpec = do - describe "Servant.API.BasicAuth" $ do - with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do - - context "Basic Authentication" $ do - let basicAuthHeaders user password = - [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))] - it "returns 401 when no credentials given" $ do - get "/basic" `shouldRespondWith` 401 +basicAuthSpec = describe "Servant.API.BasicAuth" $ with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ context "Basic Authentication" $ do + let basicAuthHeaders user password = + [("Authorization", "Basic " <> Base64.encode (user <> ":" <> password))] + it "returns 401 when no credentials given" $ do + get "/basic" `shouldRespondWith` 401 - it "returns 403 when invalid credentials given" $ do - THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" - `shouldRespondWith` 403 + it "returns 403 when invalid credentials given" $ do + THW.request methodGet "/basic" (basicAuthHeaders "servant" "wrong") "" + `shouldRespondWith` 403 - it "returns 200 with the right password" $ do - THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") "" - `shouldRespondWith` 200 + it "returns 200 with the right password" $ do + THW.request methodGet "/basic" (basicAuthHeaders "servant" "server") "" + `shouldRespondWith` 200 - it "plays nice with subsequent Raw endpoints" $ do - get "/foo" `shouldRespondWith` 418 + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 -- }}} ------------------------------------------------------------------------------ @@ -751,7 +903,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + :<|> Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -764,22 +916,85 @@ in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec -genAuthSpec = do - describe "Servant.API.Auth" $ do - with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ do +genAuthSpec = describe "Servant.API.Auth" $ with (return (serveWithContext genAuthApi genAuthContext genAuthServer)) $ context "Custom Auth Protection" $ do + it "returns 401 when missing headers" $ do + get "/auth" `shouldRespondWith` 401 - context "Custom Auth Protection" $ do - it "returns 401 when missing headers" $ do - get "/auth" `shouldRespondWith` 401 + it "returns 403 on wrong passwords" $ do + THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 - it "returns 403 on wrong passwords" $ do - THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 + it "returns 200 with the right header" $ do + THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 - it "returns 200 with the right header" $ do - THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 + it "plays nice with subsequent Raw endpoints" $ do + get "/foo" `shouldRespondWith` 418 - it "plays nice with subsequent Raw endpoints" $ do - get "/foo" `shouldRespondWith` 418 +-- }}} +------------------------------------------------------------------------------ +-- * UVerb {{{ +------------------------------------------------------------------------------ + +newtype PersonResponse = PersonResponse Person + deriving Generic +instance ToJSON PersonResponse +instance HasStatus PersonResponse where + type StatusOf PersonResponse = 200 + +newtype RedirectResponse = RedirectResponse String + deriving Generic +instance ToJSON RedirectResponse +instance HasStatus RedirectResponse where + type StatusOf RedirectResponse = 301 + +newtype AnimalResponse = AnimalResponse Animal + deriving Generic +instance ToJSON AnimalResponse +instance HasStatus AnimalResponse where + type StatusOf AnimalResponse = 203 + + +type UVerbApi + = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse] + :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse] + +uverbSpec :: Spec +uverbSpec = describe "Servant.API.UVerb " $ do + let + joe = Person "joe" 42 + mouse = Animal "Mouse" 7 + + personHandler + :: Bool + -> Handler (Union '[PersonResponse + ,RedirectResponse]) + personHandler True = respond $ RedirectResponse "over there!" + personHandler False = respond $ PersonResponse joe + + animalHandler = respond $ AnimalResponse mouse + + server :: Server UVerbApi + server = personHandler :<|> animalHandler + + with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do + context "A route returning either 301/String or 200/Person" $ do + context "when requesting the person" $ do + let theRequest = THW.get "/person/false" + it "returns status 200" $ + theRequest `shouldRespondWith` 200 + it "returns a person" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just joe + context "requesting the redirect" $ + it "returns a message and status 301" $ + THW.get "/person/true" + `shouldRespondWith` "\"over there!\"" {matchStatus = 301} + context "a route with a single response type" $ do + let theRequest = THW.get "/animal" + it "should return the defined status code" $ + theRequest `shouldRespondWith` 203 + it "should return the expected response" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just mouse -- }}} ------------------------------------------------------------------------------