diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,316 @@ [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 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + The `NoContent` API endpoints should now use `NoContentVerb` combinator. + The API type changes are usually of the kind + + ```diff + - :<|> PostNoContent '[JSON] NoContent + + :<|> PostNoContent + ``` + + i.e. one doesn't need to specify the content-type anymore. There is no content. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + You can specify a lenient capture as + + ```haskell + :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET + ``` + + which will make the capture always succeed. Handlers will be of the + type `Either String CapturedType`, where `Left err` represents + the possible parse failure. + +- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) + + 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 modifying + request's `Query`. But QueryParam, QueryParams and QueryFlag use + `rawQueryString`. By using `queryString` rather then `rawQueryString` + we can enable such rewritings. + +- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) + + 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 conveniently). + +0.16.2 +------ + +* `singleton-bool-0.1.5` (`SBool` is re-exported) + - Add `discreteBool :: Dec (a :~: b)` (GHC-7.8+) + - Add `Show`, `Eq`, `Ord` `SBool b` instances. +* dependencies update + +0.16.1 +------ + +* Use `http-api-data-0.4.1` (a part of its API is re-exported) + [#1181](https://github.com/haskell-servant/servant/pull/1181) + +0.16 +---- + +- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` + [#1131](https://github.com/haskell-servant/servant/pull/1131) +- *servant-server* Reorder HTTP failure code priorities + [#1103](https://github.com/haskell-servant/servant/pull/1103) +- *servant-server* Re-organise internal modules + [#1139](https://github.com/haskell-servant/servant/pull/1139) +- Allow `network-3.0` + [#1107](https://github.com/haskell-servant/servant/pull/1107) + +0.15 +---- + +- Streaming refactoring. + [#991](https://github.com/haskell-servant/servant/pull/991) + [#1076](https://github.com/haskell-servant/servant/pull/1076) + [#1077](https://github.com/haskell-servant/servant/pull/1077) + + The streaming functionality (`Servant.API.Stream`) is refactored to use + `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), + which replaces both `StreamGenerator` and `ResultStream` types. + + New conversion type-classes are `ToSourceIO` and `FromSourceIO` + (replacing `ToStreamGenerator` and `BuildFromStream`). + There are instances for *conduit*, *pipes* and *machines* in new packages: + [servant-conduit](https://hackage.haskell.org/package/servant-conduit) + [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and + [servant-machines](https://hackage.haskell.org/package/servant-machines) + respectively. + + Writing new framing strategies is simpler. Check existing strategies for examples. + + This change shouldn't affect you, if you don't use streaming endpoints. + +- Drop support for GHC older than 8.0 + [#1008](https://github.com/haskell-servant/servant/pull/1008) + [#1009](https://github.com/haskell-servant/servant/pull/1009) + +- *servant* NewlineFraming encodes newline after each element (i.e last) + [#1079](https://github.com/haskell-servant/servant/pull/1079) + [#1011](https://github.com/haskell-servant/servant/issues/1011) + +- *servant* Add `lookupResponseHeader :: ... => Headers headers r -> ResponseHeader h a` + [#1064](https://github.com/haskell-servant/servant/pull/1064) + +- *servant-server* Add `MonadMask Handler` + [#1068](https://github.com/haskell-servant/servant/pull/1068) + +- *servant* Export `GetHeaders'` + [#1052](https://github.com/haskell-servant/servant/pull/1052) + +- *servant* Add `Bitraversable` and other `Bi-` instances for `:<|>` + [#1032](https://github.com/haskell-servant/servant/pull/1032) + +- *servant* Add `PutCreated` method type alias + [#1024](https://github.com/haskell-servant/servant/pull/1024) + +- *servant* Add `ToSourceIO (NonEmpty a)` instance + [#988](https://github.com/haskell-servant/servant/pull/988) + +0.14.1 +------ + +- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + +- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`. + +0.14 +---- + +- `Stream` takes a status code argument + + ```diff + -Stream method framing ctype a + +Stream method status framing ctype a + ``` + + ([#966](https://github.com/haskell-servant/servant/pull/966) + [#972](https://github.com/haskell-servant/servant/pull/972)) + +- `ToStreamGenerator` definition changed, so it's possible to write an instance + for conduits. + + ```diff + -class ToStreamGenerator f a where + - toStreamGenerator :: f a -> StreamGenerator a + +class ToStreamGenerator a b | a -> b where + + toStreamGenerator :: a -> StreamGenerator b + ``` + + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- Added `NoFraming` streaming strategy + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- *servant-server* File serving in polymorphic monad. + i.e. Generalised types of `serveDirectoryFileServer` etc functions in + `Servant.Utils.StaticFiles` + ([#953](https://github.com/haskell-servant/servant/pull/953)) + +- *servant-server* `ReqBody` content type check is recoverable. + This allows writing APIs like: + + ```haskell + ReqBody '[JSON] Int :> Post '[PlainText] Int + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int + ``` + + which is useful when handlers are subtly different, + for example may do less work. + ([#937](https://github.com/haskell-servant/servant/pull/937)) + + 0.13.0.1 -------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,4 +6,4 @@ ## Getting started -We've written a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. +We've written a [tutorial](http://docs.servant.dev/en/stable/tutorial/index.html) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,31 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif - -\end{code} diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -1,12 +1,15 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +import Prelude () +import Prelude.Compat + import Data.Aeson -import Data.Monoid import Data.Proxy import Data.Text import GHC.Generics @@ -14,6 +17,7 @@ import Network.Wai.Handler.Warp import Servant +import Servant.Server.Generic () -- * Example @@ -36,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 @@ -46,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/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,195 +1,212 @@ -name: servant-server -version: 0.13.0.1 -synopsis: A family of combinators for defining webservices APIs and serving them +cabal-version: 3.0 +name: servant-server +version: 0.20.3.0 +synopsis: + A family of combinators for defining webservices APIs and serving them + +category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . - You can learn about the basics in the . + You can learn about the basics in the . . is a runnable example, with comments, that defines a dummy API and implements a webserver that serves this API, using this package. . -homepage: http://haskell-servant.readthedocs.org/ -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, Servant Contributors -category: Servant, Web -build-type: Custom -cabal-version: >=1.10 -tested-with: - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.2, - GHC==8.2.2, - GHC==8.4.1 + +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: - include/*.h CHANGELOG.md README.md source-repository head - type: git + type: git location: http://github.com/haskell-servant/servant.git -custom-setup - setup-depends: - base >= 4 && <5, - Cabal, - cabal-doctest >= 1.0.1 && <1.1 +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 Servant.Server.Experimental.Auth + Servant.Server.Generic Servant.Server.Internal Servant.Server.Internal.BasicAuth Servant.Server.Internal.Context + Servant.Server.Internal.Delayed + Servant.Server.Internal.DelayedIO + Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler + Servant.Server.Internal.ResponseRender + Servant.Server.Internal.RouteResult Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication - Servant.Server.Internal.ServantErr - Servant.Utils.StaticFiles + Servant.Server.Internal.ServerError + Servant.Server.StaticFiles + Servant.Server.UVerb + -- deprecated + 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 - -- - -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.12 - , bytestring >= 0.10.4.0 && < 0.11 - , containers >= 0.5.5.1 && < 0.6 - , mtl >= 2.1 && < 2.3 - , text >= 1.2.3.0 && < 1.3 - , transformers >= 0.3.0.0 && < 0.6 - , filepath >= 1.3.0.2 && < 1.5 - - if !impl(ghc >= 8.0) - build-depends: - semigroups >= 0.18.3 && < 0.19 + , 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.13.* + , 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: - aeson >= 1.2.3.0 && < 1.4 - , base-compat >= 0.9.3 && < 0.11 - , attoparsec >= 0.13.2.0 && < 0.14 - , base64-bytestring >= 1.0.0.1 && < 1.1 - , exceptions >= 0.8.3 && < 0.11 - , http-api-data >= 0.3.7.1 && < 0.4 - , http-media >= 0.7.0 && < 0.8 - , http-types >= 0.12 && < 0.13 - , network-uri >= 2.6.1.0 && < 2.7 - , monad-control >= 1.0.0.4 && < 1.1 - , network >= 2.6.3.2 && < 2.7 - , safe >= 0.3.15 && < 0.4 - , split >= 0.2.3.2 && < 0.3 - , string-conversions >= 0.4.0.1 && < 0.5 - , system-filepath >= 0.4 && < 0.5 - , resourcet >= 1.1.9 && < 1.3 - , tagged >= 0.8.5 && < 0.9 - , transformers-base >= 0.4.4 && < 0.5 - , transformers-compat >= 0.5.1 && < 0.7 - , wai >= 3.2.1.1 && < 3.3 - , wai-app-static >= 3.1.6.1 && < 3.2 - , warp >= 3.2.13 && < 3.3 - , 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 - if impl(ghc >= 8.0) - ghc-options: -Wno-redundant-constraints - include-dirs: include + 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 - , servant + , base + , base-compat , servant-server - , aeson - , warp - , wai , text + , wai + build-depends: + , 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.StreamingSpec - Servant.Server.UsingContextSpec - Servant.Server.UsingContextSpec.TestCombinators - Servant.HoistSpec - Servant.ServerSpec - Servant.Utils.StaticFilesSpec + 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 - , aeson , base64-bytestring , bytestring - , exceptions , http-types , mtl - , network , resourcet , safe , servant , servant-server - , string-conversions , text - , transformers - , transformers-compat , wai - , warp - -- Additonal dependencies + -- Additional dependencies build-depends: - directory >= 1.2.1.0 && < 1.4 - , hspec >= 2.4.4 && < 2.6 - , hspec-wai >= 0.9 && < 0.10 - , should-not-typecheck >= 2.1.0 && < 2.2 - , parsec >= 3.1.11 && < 3.2 - , QuickCheck >= 2.10.1 && < 2.12 - , wai-extra >= 3.0.21.0 && < 3.1 - , temporary >= 1.2.0.3 && < 1.4 - - build-tool-depends: - hspec-discover:hspec-discover >=2.4.4 && <2.6 + , 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 -test-suite doctests - build-depends: - base - , servant-server - , doctest >= 0.13.0 && <0.16 - type: exitcode-stdio-1.0 - main-is: test/doctests.hs - buildable: True - default-language: Haskell2010 - ghc-options: -Wall -threaded - if impl(ghc >= 8.2) - x-doctest-options: -fdiagnostics-color=never - include-dirs: include + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -6,16 +6,17 @@ -- | For implementing servers for servant APIs. module Servant.Server, -- | Utilities on top of the servant core - module Servant.Utils.Links, - module Servant.Utils.StaticFiles, + module Servant.Links, + module Servant.Server.StaticFiles, -- | Useful re-exports Proxy(..), throwError ) where -import Control.Monad.Error.Class (throwError) +import Control.Monad.Error.Class + (throwError) import Data.Proxy import Servant.API +import Servant.Links import Servant.Server -import Servant.Utils.Links -import Servant.Utils.StaticFiles +import Servant.Server.StaticFiles 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 @@ -49,7 +57,7 @@ -- , mkAuthHandler -- * Default error type - , ServantErr(..) + , ServerError(..) -- ** 3XX , err300 , err301 @@ -78,6 +86,7 @@ , err417 , err418 , err422 + , err429 -- ** 5XX , err500 , err501 @@ -86,27 +95,60 @@ , 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 -import Data.Proxy (Proxy (..)) -import Data.Tagged (Tagged (..)) -import Data.Text (Text) -import Network.Wai (Application) +import Data.Proxy + (Proxy (..)) +import Data.Tagged + (Tagged (..)) +import Data.Text + (Text) +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: -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > server :: Server MyApi -- > server = listAllBooks :<|> postBook @@ -125,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 @@ -179,7 +238,7 @@ -- > │ └─ e/ -- > │ └─• -- > ├─ b/ --- > │ └─ / +-- > │ └─ / -- > │ ├─• -- > │ ┆ -- > │ └─• @@ -196,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,33 +1,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Experimental.Auth where -import Control.Monad.Trans (liftIO) -import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Network.Wai (Request) +import Control.Monad.Trans + (liftIO) +import Data.Kind + (Type) +import Data.Proxy + (Proxy (Proxy)) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.Wai + (Request) -import Servant ((:>)) +import Servant + ((:>)) import Servant.API.Experimental.Auth -import Servant.Server.Internal (HasContextEntry, - HasServer (..), - getContextEntry) -import Servant.Server.Internal.RoutingApplication (addAuthCheck, - delayedFailFatal, - DelayedIO, - withRequest) -import Servant.Server.Internal.Handler (Handler, runHandler) +import Servant.Server.Internal + (DelayedIO, Handler, HasContextEntry, HasServer (..), + addAuthCheck, delayedFailFatal, getContextEntry, runHandler, + withRequest) -- * General Auth @@ -35,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 new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Generic.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | @since 0.14.1 +module Servant.Server.Generic ( + AsServerT, + AsServer, + genericServe, + genericServeT, + genericServeTWithContext, + genericServer, + genericServerT + ) where + +import Data.Kind + (Type) +import Data.Proxy + (Proxy (..)) + +import Servant.Server +import Servant.API.Generic +import Servant.Server.Internal + +-- | Transform a record of routes into a WAI 'Application'. +genericServe + :: forall routes. + ( HasServer (ToServantApi routes) '[] + , GenericServant routes AsServer + , Server (ToServantApi routes) ~ ToServant routes AsServer + ) + => routes AsServer -> Application +genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer + +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- by providing a transformation to bring each handler back in the 'Handler' +-- monad. +genericServeT + :: forall (routes :: Type -> Type) (m :: Type -> Type). + ( GenericServant routes (AsServerT m) + , GenericServant routes AsApi + , HasServer (ToServantApi routes) '[] + , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) + ) + => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Application +genericServeT f server = serve p $ hoistServer p f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + +-- | Transform a record of routes with custom monad into a WAI 'Application', +-- while using the given 'Context' to serve the application (contexts are typically +-- 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 :: 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' + -> routes (AsServerT m) -- ^ your record full of request handlers + -> Context ctx -- ^ the 'Context' to serve the application with + -> Application +genericServeTWithContext f server ctx = + serveWithContext p ctx $ + hoistServerWithContext p pctx f (genericServerT server) + where + p = genericApi (Proxy :: Proxy routes) + pctx = Proxy :: Proxy ctx + +-- | 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,109 +1,103 @@ -{-# 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 - -#ifdef HAS_TYPE_ERROR -{-# LANGUAGE UndecidableInstances #-} -#endif - -#include "overlapping-compat.h" +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} module Servant.Server.Internal ( module Servant.Server.Internal , module Servant.Server.Internal.BasicAuth , 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 , module Servant.Server.Internal.RoutingApplication - , module Servant.Server.Internal.ServantErr + , module Servant.Server.Internal.ServerError ) where -import Control.Monad (join, when) -import Control.Monad.Trans (liftIO) -import Control.Monad.Trans.Resource (runResourceT) -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 Data.Maybe (fromMaybe, mapMaybe, - isNothing, maybeToList) -import Data.Either (partitionEithers) -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 Control.Monad + (join, when, unless) +import Control.Monad.Trans + (liftIO, lift) +import Control.Monad.Trans.Resource + (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 BSL +import Data.Constraint (Constraint, Dict(..)) +import Data.Either + (partitionEithers) +import Data.Kind + (Type) +import Data.Maybe + (fromMaybe, isNothing, mapMaybe, maybeToList) +import Data.String + (IsString (..)) +import Data.Tagged + (Tagged (..), retag, untag) +import qualified Data.Text as T import Data.Typeable -import GHC.TypeLits (KnownNat, KnownSymbol, natVal, - symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import qualified Network.HTTP.Media as NHM -import Network.Socket (SockAddr) -import Network.Wai (Application, Request, - httpVersion, isSecure, - lazyRequestBody, - rawQueryString, remoteHost, - requestHeaders, requestMethod, - responseLBS, responseStream, - vault) -import Prelude () -import Prelude.Compat -import Web.HttpApiData (FromHttpApiData, parseHeader, - parseQueryParam, - parseUrlPieceMaybe, - parseUrlPieces) -import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', - CaptureAll, Verb, EmptyAPI, - ReflectMethod(reflectMethod), - IsSecure(..), Header', QueryFlag, - QueryParam', QueryParams, Raw, - RemoteHost, ReqBody', Vault, - WithNamedContext, - Description, Summary, - Accept(..), - FramingRender(..), Stream, - StreamGenerator(..), ToStreamGenerator(..), - BoundaryStrategy(..), - If, SBool (..), SBoolI (..)) -import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient) -import Servant.API.ContentTypes (AcceptHeader (..), - AllCTRender (..), - AllCTUnrender (..), - AllMime, - MimeRender(..), - canHandleAcceptH) -import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, - getResponse) +import GHC.Generics +import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal) +import qualified Network.HTTP.Media as NHM +import Network.HTTP.Types hiding + (statusCode, Header, ResponseHeaders) +import Network.Socket + (SockAddr) +import Network.Wai + (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody, + queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestHeaderHost, + requestMethod, responseLBS, responseStream, vault) +import Servant.API + ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', + 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 (..), 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, parseUrlPiece, + parseUrlPieces) -import Servant.Server.Internal.Context 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.ServantErr - -#ifdef HAS_TYPE_ERROR -import GHC.TypeLits (TypeError, ErrorMessage (..)) -#endif +import Servant.Server.Internal.ServerError +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 @@ -164,22 +158,31 @@ -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) +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 = - a -> ServerT api m + If (FoldLenient mods) (Either String a) a -> ServerT api m 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 parseUrlPieceMaybe txt of - Nothing -> delayedFail err400 - Just v -> return v - ) + (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 @@ -198,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 = @@ -207,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 @@ -234,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)) @@ -247,18 +293,29 @@ 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 -instance OVERLAPPABLE_ +noContentRouter :: Method + -> Status + -> Delayed env (Handler b) + -> Router env +noContentRouter method status action = leafRouter route' + where + route' env request respond = + runAction (action `addMethodCheck` methodCheck method request) + env request respond $ \ _output -> + Route $ responseLBS status [] "" + +instance {-# OVERLAPPABLE #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status ) => HasServer (Verb method status ctypes a) context where @@ -267,9 +324,9 @@ 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_ +instance {-# OVERLAPPING #-} ( AllCTRender ctypes a, ReflectMethod method, KnownNat status , GetHeaders (Headers h a) ) => HasServer (Verb method status ctypes (Headers h a)) context where @@ -279,42 +336,54 @@ 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 -instance OVERLAPPABLE_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a - ) => HasServer (Stream method framing ctype (f a)) context where + type ServerT (NoContentVerb method) m = m NoContent + hoistServerWithContext _ _ nt s = nt s - type ServerT (Stream method framing ctype (f a)) m = m (f a) + route Proxy _ = noContentRouter method status204 + where method = reflectMethod (Proxy :: Proxy method) + +instance {-# OVERLAPPABLE #-} + ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, + FramingRender framing, ToSourceIO chunk a + ) => HasServer (Stream method status framing ctype a) context where + + type ServerT (Stream method status framing ctype a) m = m a hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) -instance OVERLAPPING_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a, - GetHeaders (Headers h (f a)) - ) => HasServer (Stream method framing ctype (Headers h (f a))) context where - type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a)) +instance {-# OVERLAPPING #-} + ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, + FramingRender framing, ToSourceIO chunk a, + GetHeaders (Headers h a) + ) => HasServer (Stream method status framing ctype (Headers h a)) context where + + type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a) hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) => - (b -> ([(HeaderName, B.ByteString)], f a)) +streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) => + (c -> ([(HeaderName, B.ByteString)], a)) -> Method + -> Status -> Proxy framing -> Proxy ctype - -> Delayed env (Handler b) + -> Delayed env (Handler c) -> Router env -streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request +streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> + let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) @@ -322,29 +391,20 @@ `addAcceptCheck` accCheck ) env request respond $ \ output -> let (headers, fa) = splitHeaders output - k = getStreamGenerator . toStreamGenerator $ fa in - Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do - write . BB.lazyByteString $ header framingproxy ctypeproxy - case boundary framingproxy ctypeproxy of - BoundaryStrategyBracket f -> - let go x = let bs = mimeRender ctypeproxy x - (before, after) = f bs - in write ( BB.lazyByteString before - <> BB.lazyByteString bs - <> BB.lazyByteString after) >> flush - in k go go - BoundaryStrategyIntersperse sep -> k - (\x -> do - write . BB.lazyByteString . mimeRender ctypeproxy $ x - flush) - (\x -> do - write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x - flush) - BoundaryStrategyGeneral f -> - let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy - in k go go - write . BB.lazyByteString $ trailer framingproxy ctypeproxy + sourceT = toSourceIO fa + 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 + loop (S.Skip s) = loop s + loop (S.Effect ms) = ms >>= loop + loop (S.Yield lbs s) = do + write (BB.lazyByteString lbs) + flush + loop s + kStepLBS loop + -- | If you use 'Header' 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 'Header'. @@ -368,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 ------ @@ -379,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) @@ -389,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'@. @@ -423,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 ------ @@ -432,9 +519,12 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = - let querytext req = parseQueryText $ rawQueryString req - paramname = cs $ symbolVal (Proxy :: Proxy sym) + let querytext = queryToQueryText . queryString + 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 @@ -442,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 @@ -475,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 = @@ -486,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) - . parseQueryText - . rawQueryString + . queryToQueryText + . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") @@ -526,16 +617,115 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = - let querytext r = parseQueryText $ rawQueryString r + let querytext = queryToQueryText . queryString param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value 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: @@ -562,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. -- @@ -584,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 = @@ -595,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 @@ -603,8 +826,8 @@ -- 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 - Nothing -> delayedFailFatal err415 + case canHandleCTypeH (Proxy :: Proxy list) (BSL.fromStrict contentTypeH) :: Maybe (BSL.ByteString -> Either String a) of + Nothing -> delayedFail err415 Just f -> return f -- Body check, we get a body parsing functions as the first argument. @@ -613,9 +836,33 @@ 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 + ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk + , HasServer api context + ) => HasServer (StreamBody' mods framing ctype a :> api) context + where + type ServerT (StreamBody' mods framing ctype 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 $ + addBodyCheck subserver ctCheck bodyCheck + where + ctCheck :: DelayedIO (SourceIO chunk -> IO a) + -- TODO: do content-type check + ctCheck = return fromSourceIO + + bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a + bodyCheck fromRS = withRequest $ \req -> do + 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 = getRequestBodyChunk req + let rs = S.fromAction B.null body + liftIO $ fromRS $ framingUnrender' rs + -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where @@ -624,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 @@ -680,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 @@ -693,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 @@ -714,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 @@ -739,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 "...") @@ -805,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 @@ -1,29 +1,36 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.BasicAuth where -import Control.Monad (guard) -import Control.Monad.Trans (liftIO) -import qualified Data.ByteString as BS -import Data.ByteString.Base64 (decodeLenient) -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Data.Word8 (isSpace, toLower, _colon) +import Control.Monad + (guard) +import Control.Monad.Trans + (liftIO) +import qualified Data.ByteString as BS +import Data.ByteString.Base64 + (decodeLenient) +import Data.Typeable + (Typeable) +import Data.Word8 + (isSpace, toLower, _colon) import GHC.Generics -import Network.HTTP.Types (Header) -import Network.Wai (Request, requestHeaders) +import Network.HTTP.Types + (Header) +import Network.Wai + (Request, requestHeaders) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) -import Servant.Server.Internal.RoutingApplication -import Servant.Server.Internal.ServantErr +import Servant.API.BasicAuth + (BasicAuthData (BasicAuthData)) +import Servant.Server.Internal.DelayedIO +import Servant.Server.Internal.ServerError -- * 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,29 +1,33 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -#include "overlapping-compat.h" +{-# 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 -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using --- with 'Servant.Utils.Enter'.) If you don't use combinators that +-- with 'hoistServer'.) If you don't use combinators that -- require any context entries, you can just use 'Servant.Server.serve' as always. -- -- 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 @@ -48,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: -- @@ -59,16 +68,16 @@ -- -- >>> 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_ +instance {-# OVERLAPPABLE #-} HasContextEntry xs val => HasContextEntry (notIt ': xs) val where getContextEntry (_ :. xs) = getContextEntry xs -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} HasContextEntry (val ': xs) val where getContextEntry (x :. _) = x @@ -78,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 new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Delayed.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.Internal.Delayed where + +import Control.Monad.IO.Class + (MonadIO (..)) +import Control.Monad.Reader + (ask) +import Control.Monad.Trans.Resource + (ResourceT, runResourceT) +import Network.Wai + (Request, Response) + +import Servant.Server.Internal.DelayedIO +import Servant.Server.Internal.Handler +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.ServerError + +-- | A 'Delayed' is a representation of a handler with scheduled +-- delayed checks that can trigger errors. +-- +-- Why would we want to delay checks? +-- +-- There are two reasons: +-- +-- 1. In a straight-forward implementation, the order in which we +-- perform checks will determine the error we generate. This is +-- because once an error occurs, we would abort and not perform +-- any subsequent checks, but rather return the current error. +-- +-- This is not a necessity: we could continue doing other checks, +-- and choose the preferred error. However, that would in general +-- mean more checking, which leads us to the other reason. +-- +-- 2. We really want to avoid doing certain checks too early. For +-- example, captures involve parsing, and are much more costly +-- than static route matches. In particular, if several paths +-- contain the "same" capture, we'd like as much as possible to +-- avoid trying the same parse many times. Also tricky is the +-- request body. Again, this involves parsing, but also, WAI makes +-- obtaining the request body a side-effecting operation. We +-- could/can work around this by manually caching the request body, +-- but we'd rather keep the number of times we actually try to +-- decode the request body to an absolute minimum. +-- +-- We prefer to have the following relative priorities of error +-- codes: +-- +-- @ +-- 404 +-- 405 (bad method) +-- 401 (unauthorized) +-- 415 (unsupported media type) +-- 406 (not acceptable) +-- 400 (bad request) +-- @ +-- +-- Therefore, while routing, we delay most checks so that they +-- will ultimately occur in the right order. +-- +-- A 'Delayed' contains many delayed blocks of tests, and +-- the actual handler: +-- +-- 1. Delayed captures. These can actually cause 404, and +-- while they're costly, they should be done first among the +-- delayed checks (at least as long as we do not decouple the +-- check order from the error reporting, see above). Delayed +-- captures can provide inputs to the actual handler. +-- +-- 2. Method check(s). This can cause a 405. On success, +-- it does not provide an input for the handler. Method checks +-- are comparatively cheap. +-- +-- 3. Authentication checks. This can cause 401. +-- +-- 4. Accept and content type header checks. These checks +-- can cause 415 and 406 errors. +-- +-- 5. Query parameter checks. They require parsing and can cause 400 if the +-- parsing fails. Query parameter checks provide inputs to the handler +-- +-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails. +-- +-- 7. Body check. The request body check can cause 400. +-- +data Delayed env c where + Delayed :: { capturesD :: env -> DelayedIO captures + , methodD :: DelayedIO () + , authD :: DelayedIO auth + , acceptD :: DelayedIO () + , contentD :: DelayedIO contentType + , paramsD :: DelayedIO params + , headersD :: DelayedIO headers + , bodyD :: contentType -> DelayedIO body + , serverD :: captures + -> params + -> headers + -> auth + -> body + -> Request + -> RouteResult c + } -> Delayed env c + +instance Functor (Delayed env) where + fmap f Delayed{..} = + Delayed + { serverD = \ c p h a b req -> f <$> serverD c p h a b req + , .. + } -- Note [Existential Record Update] + +-- | A 'Delayed' without any stored checks. +emptyDelayed :: RouteResult a -> Delayed env a +emptyDelayed result = + Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) + where + r = return () + +-- | Add a capture to the end of the capture block. +addCapture :: Delayed env (a -> b) + -> (captured -> DelayedIO a) + -> Delayed (captured, env) b +addCapture Delayed{..} new = + Delayed + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt + , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req + , .. + } -- Note [Existential Record Update] + +-- | Add a parameter check to the end of the params block +addParameterCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addParameterCheck Delayed {..} new = + Delayed + { paramsD = (,) <$> paramsD <*> new + , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req + , .. + } + +-- | Add a parameter check to the end of the params block +addHeaderCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addHeaderCheck Delayed {..} new = + Delayed + { headersD = (,) <$> headersD <*> new + , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req + , .. + } + +-- | Add a method check to the end of the method block. +addMethodCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addMethodCheck Delayed{..} new = + Delayed + { methodD = methodD <* new + , .. + } -- Note [Existential Record Update] + +-- | Add an auth check to the end of the auth block. +addAuthCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addAuthCheck Delayed{..} new = + Delayed + { authD = (,) <$> authD <*> new + , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req + , .. + } -- Note [Existential Record Update] + +-- | Add a content type and body checks around parameter checks. +-- +-- We'll report failed content type check (415), before trying to parse +-- query parameters (400). Which, in turn, happens before request body parsing. +addBodyCheck :: Delayed env (a -> b) + -> DelayedIO c -- ^ content type check + -> (c -> DelayedIO a) -- ^ body check + -> Delayed env b +addBodyCheck Delayed{..} newContentD newBodyD = + Delayed + { contentD = (,) <$> contentD <*> newContentD + , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c + , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req + , .. + } -- Note [Existential Record Update] + + +-- | Add an accept header check before handling parameters. +-- In principle, we'd like +-- to take a bad body (400) response take precedence over a +-- failed accept check (406). BUT to allow streaming the body, +-- we cannot run the body check and then still backtrack. +-- We therefore do the accept check before the body check, +-- when we can still backtrack. There are other solutions to +-- this, but they'd be more complicated (such as delaying the +-- body check further so that it can still be run in a situation +-- where we'd otherwise report 406). +addAcceptCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addAcceptCheck Delayed{..} new = + Delayed + { acceptD = acceptD *> new + , .. + } -- Note [Existential Record Update] + +-- | Many combinators extract information that is passed to +-- the handler without the possibility of failure. In such a +-- case, 'passToServer' can be used. +passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b +passToServer Delayed{..} x = + Delayed + { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req + , .. + } -- Note [Existential Record Update] + +-- | Run a delayed server. Performs all scheduled operations +-- in order, and passes the results from the capture and body +-- blocks on to the actual handler. +-- +-- This should only be called once per request; otherwise the guarantees about +-- effect and HTTP error ordering break down. +runDelayed :: Delayed env a + -> env + -> Request + -> ResourceT IO (RouteResult a) +runDelayed Delayed{..} env = runDelayedIO $ do + r <- ask + c <- capturesD env + methodD + a <- authD + acceptD + content <- contentD + p <- paramsD -- Has to be before body parsing, but after content-type checks + h <- headersD + b <- bodyD content + liftRouteResult (serverD c p h a b r) + +-- | Runs a delayed server and the resulting action. +-- Takes a continuation that lets us send a response. +-- Also takes a continuation for how to turn the +-- result of the delayed server into a response. +runAction :: Delayed env (Handler a) + -> env + -> Request + -> (RouteResult Response -> IO r) + -> (a -> RouteResult Response) + -> IO r +runAction action env req respond k = runResourceT $ + runDelayed action env req >>= go >>= liftIO . respond + where + go (Fail e) = return $ Fail e + go (FailFatal e) = return $ FailFatal e + go (Route a) = liftIO $ do + e <- runHandler a + case e of + Left err -> return . Route $ responseServerError err + Right x -> return $! k x + +{- Note [Existential Record Update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Due to GHC issue , we cannot +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 new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/DelayedIO.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Server.Internal.DelayedIO where + +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadThrow (..)) +import Control.Monad.Reader + (MonadReader (..), ReaderT (..), runReaderT) +import Control.Monad.Trans + (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control + (MonadBaseControl (..)) +import Control.Monad.Trans.Resource + (MonadResource (..), ResourceT, runInternalState, + transResourceT, withInternalState) +import Network.Wai + (Request) + +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.ServerError + +-- | Computations used in a 'Delayed' can depend on the +-- incoming 'Request', may perform 'IO', and result in a +-- '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 newtype + ( Functor, Applicative, Monad + , MonadIO, MonadReader Request + , MonadThrow + , MonadResource + ) + +instance MonadBase IO DelayedIO where + liftBase = liftIO + +liftRouteResult :: RouteResult a -> DelayedIO a +liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x + +instance MonadBaseControl IO DelayedIO where + -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a + -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') + -- restoreM = DelayedIO . restoreM + + type StM DelayedIO a = RouteResult a + liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s -> + liftBaseWith $ \runInBase -> f $ \x -> + runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) + restoreM = DelayedIO . lift . withInternalState . const . restoreM + + +runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) +runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req + +-- | Fail with the option to recover. +delayedFail :: ServerError -> DelayedIO a +delayedFail err = liftRouteResult $ Fail err + +-- | Fail fatally, i.e., without any option to recover. +delayedFailFatal :: ServerError -> DelayedIO a +delayedFailFatal err = liftRouteResult $ FailFatal err + +-- | Gain access to the incoming request. +withRequest :: (Request -> DelayedIO a) -> DelayedIO a +withRequest f = do + req <- ask + f req 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,34 +1,45 @@ {-# 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, MonadThrow) -import Control.Monad.Error.Class (MonadError) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Except (ExceptT, runExceptT) -import GHC.Generics (Generic) -import Servant.Server.Internal.ServantErr (ServantErr) +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Error.Class + (MonadError, throwError) +import Control.Monad.IO.Class + (MonadIO) +import Control.Monad.Trans.Control + (MonadBaseControl (..)) +import Control.Monad.Trans.Except + (ExceptT(ExceptT), runExceptT) +import Data.String + (fromString) +import GHC.Generics + (Generic) +import Servant.Server.Internal.ServerError + (ServerError, errBody, err500) -newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a } - deriving - ( Functor, Applicative, Monad, MonadIO, Generic - , MonadError ServantErr - , MonadThrow, MonadCatch +newtype Handler a = Handler { runHandler' :: ExceptT ServerError IO a } + 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 instance MonadBaseControl IO Handler where - type StM Handler a = Either ServantErr a + type StM Handler a = Either ServerError a -- liftBaseWith :: (RunInBase Handler IO -> IO a) -> Handler a liftBaseWith f = Handler (liftBaseWith (\g -> f (g . runHandler'))) @@ -36,5 +47,12 @@ -- restoreM :: StM Handler a -> Handler a restoreM st = Handler (restoreM st) -runHandler :: Handler a -> IO (Either ServantErr a) +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 new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/RouteResult.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.Internal.RouteResult where + +import Control.Monad + (ap, liftM) +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Catch + (MonadThrow (..)) +import Control.Monad.Trans + (MonadIO (..), MonadTrans (..)) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl (..), MonadTransControl (..), + defaultLiftBaseWith, defaultRestoreM) + +import Servant.Server.Internal.ServerError + +-- | The result of matching against a path in the route tree. +data RouteResult a = + Fail ServerError -- ^ Keep trying other paths. + -- The 'ServantError' should only be 404, 405 or 406. + | FailFatal !ServerError -- ^ Don't try other paths. + | Route !a + deriving (Eq, Show, Read, Functor) + +instance Applicative RouteResult where + pure = Route + (<*>) = ap + +instance Monad RouteResult where + return = pure + Route a >>= f = f a + Fail e >>= _ = Fail e + FailFatal e >>= _ = FailFatal e + +newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } + deriving (Functor) + +instance MonadTrans RouteResultT where + lift = RouteResultT . fmap Route + +instance (Functor m, Monad m) => Applicative (RouteResultT m) where + pure = RouteResultT . return . Route + (<*>) = ap + +instance Monad m => Monad (RouteResultT m) where + return = pure + m >>= k = RouteResultT $ do + a <- runRouteResultT m + case a of + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + Route b -> runRouteResultT (k b) + +instance MonadIO m => MonadIO (RouteResultT m) where + liftIO = lift . liftIO + +instance MonadBase b m => MonadBase b (RouteResultT m) where + liftBase = lift . liftBase + +instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where + type StM (RouteResultT m) a = ComposeSt RouteResultT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +instance MonadTransControl RouteResultT where + type StT RouteResultT a = RouteResult a + liftWith f = RouteResultT $ liftM return $ f runRouteResultT + restoreT = RouteResultT + +instance MonadThrow m => MonadThrow (RouteResultT m) where + throwM = lift . throwM 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 @@ -1,20 +1,45 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where -import Data.Map (Map) +import Data.Function + (on) +import Data.List + (nub) +import Data.Map + (Map) import qualified Data.Map as M -import Data.Monoid -import Data.Text (Text) +import Data.Text + (Text) import qualified Data.Text as T -import Network.Wai (Response, pathInfo) +import Data.Typeable + (TypeRep) +import Network.Wai + (Response, pathInfo) +import Servant.Server.Internal.ErrorFormatter +import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication -import Servant.Server.Internal.ServantErr +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 @@ -27,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) @@ -60,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 @@ -75,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) @@ -89,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 @@ -105,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. @@ -117,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) = @@ -145,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 @@ -203,7 +247,14 @@ -- Priority on HTTP codes. -- --- It just so happens that 404 < 405 < 406 as far as --- we are concerned here, so we can use (<). worseHTTPCode :: Int -> Int -> Bool -worseHTTPCode = (<) +worseHTTPCode = on (<) toPriority + where + toPriority :: Int -> Int + toPriority 404 = 0 -- not found + toPriority 405 = 1 -- method not allowed + toPriority 401 = 2 -- unauthorized + toPriority 415 = 3 -- unsupported media type + toPriority 406 = 4 -- not acceptable + toPriority 400 = 6 -- bad request + toPriority _ = 5 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 @@ -1,390 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad (ap, liftM) -import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadThrow (..)) -import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT) -import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) -import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), - defaultLiftBaseWith, defaultRestoreM) -import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState) -import Network.Wai (Application, Request, Response, ResponseReceived) -import Prelude () -import Prelude.Compat -import Servant.Server.Internal.Handler -import Servant.Server.Internal.ServantErr +import Network.Wai + (Application, Request, Response, ResponseReceived) +import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.ServerError type RoutingApplication = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived --- | The result of matching against a path in the route tree. -data RouteResult a = - Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@ - -- should only be 404, 405 or 406. - | FailFatal !ServantErr -- ^ Don't try other paths. - | Route !a - deriving (Eq, Show, Read, Functor) - -instance Applicative RouteResult where - pure = return - (<*>) = ap - -instance Monad RouteResult where - return = Route - Route a >>= f = f a - Fail e >>= _ = Fail e - FailFatal e >>= _ = FailFatal e - -newtype RouteResultT m a = RouteResultT { runRouteResultT :: m (RouteResult a) } - deriving (Functor) - -instance MonadTrans RouteResultT where - lift = RouteResultT . liftM Route - -instance (Functor m, Monad m) => Applicative (RouteResultT m) where - pure = return - (<*>) = ap - -instance Monad m => Monad (RouteResultT m) where - return = RouteResultT . return . Route - m >>= k = RouteResultT $ do - a <- runRouteResultT m - case a of - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e - Route b -> runRouteResultT (k b) - -instance MonadIO m => MonadIO (RouteResultT m) where - liftIO = lift . liftIO - -instance MonadBase b m => MonadBase b (RouteResultT m) where - liftBase = lift . liftBase - -instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where - type StM (RouteResultT m) a = ComposeSt RouteResultT m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance MonadTransControl RouteResultT where - type StT RouteResultT a = RouteResult a - liftWith f = RouteResultT $ liftM return $ f runRouteResultT - restoreT = RouteResultT - -instance MonadThrow m => MonadThrow (RouteResultT m) where - throwM = lift . throwM - toApplication :: RoutingApplication -> Application toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived - routingRespond (Fail err) = respond $ responseServantErr err - routingRespond (FailFatal err) = respond $ responseServantErr err + routingRespond (Fail err) = respond $ responseServerError err + routingRespond (FailFatal err) = respond $ responseServerError err routingRespond (Route v) = respond v - --- | A 'Delayed' is a representation of a handler with scheduled --- delayed checks that can trigger errors. --- --- Why would we want to delay checks? --- --- There are two reasons: --- --- 1. In a straight-forward implementation, the order in which we --- perform checks will determine the error we generate. This is --- because once an error occurs, we would abort and not perform --- any subsequent checks, but rather return the current error. --- --- This is not a necessity: we could continue doing other checks, --- and choose the preferred error. However, that would in general --- mean more checking, which leads us to the other reason. --- --- 2. We really want to avoid doing certain checks too early. For --- example, captures involve parsing, and are much more costly --- than static route matches. In particular, if several paths --- contain the "same" capture, we'd like as much as possible to --- avoid trying the same parse many times. Also tricky is the --- request body. Again, this involves parsing, but also, WAI makes --- obtaining the request body a side-effecting operation. We --- could/can work around this by manually caching the request body, --- but we'd rather keep the number of times we actually try to --- decode the request body to an absolute minimum. --- --- We prefer to have the following relative priorities of error --- codes: --- --- @ --- 404 --- 405 (bad method) --- 401 (unauthorized) --- 415 (unsupported media type) --- 406 (not acceptable) --- 400 (bad request) --- @ --- --- Therefore, while routing, we delay most checks so that they --- will ultimately occur in the right order. --- --- A 'Delayed' contains many delayed blocks of tests, and --- the actual handler: --- --- 1. Delayed captures. These can actually cause 404, and --- while they're costly, they should be done first among the --- delayed checks (at least as long as we do not decouple the --- check order from the error reporting, see above). Delayed --- captures can provide inputs to the actual handler. --- --- 2. Method check(s). This can cause a 405. On success, --- it does not provide an input for the handler. Method checks --- are comparatively cheap. --- --- 3. Authentication checks. This can cause 401. --- --- 4. Accept and content type header checks. These checks --- can cause 415 and 406 errors. --- --- 5. Query parameter checks. They require parsing and can cause 400 if the --- parsing fails. Query parameter checks provide inputs to the handler --- --- 6. Header Checks. They also require parsing and can cause 400 if parsing fails. --- --- 7. Body check. The request body check can cause 400. --- -data Delayed env c where - Delayed :: { capturesD :: env -> DelayedIO captures - , methodD :: DelayedIO () - , authD :: DelayedIO auth - , acceptD :: DelayedIO () - , contentD :: DelayedIO contentType - , paramsD :: DelayedIO params - , headersD :: DelayedIO headers - , bodyD :: contentType -> DelayedIO body - , serverD :: captures - -> params - -> headers - -> auth - -> body - -> Request - -> RouteResult c - } -> Delayed env c - -instance Functor (Delayed env) where - fmap f Delayed{..} = - Delayed - { serverD = \ c p h a b req -> f <$> serverD c p h a b req - , .. - } -- Note [Existential Record Update] - --- | 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 --- (with the possibility to recover), or fail fatally. --- -newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } - deriving - ( Functor, Applicative, Monad - , MonadIO, MonadReader Request - , MonadThrow - , MonadResource - ) - -instance MonadBase IO DelayedIO where - liftBase = liftIO - -liftRouteResult :: RouteResult a -> DelayedIO a -liftRouteResult x = DelayedIO $ lift . lift $ RouteResultT . return $ x - -instance MonadBaseControl IO DelayedIO where - -- type StM DelayedIO a = StM (ReaderT Request (ResourceT (RouteResultT IO))) a - -- liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') - -- restoreM = DelayedIO . restoreM - - type StM DelayedIO a = RouteResult a - liftBaseWith f = DelayedIO $ ReaderT $ \req -> withInternalState $ \s -> - liftBaseWith $ \runInBase -> f $ \x -> - runInBase (runInternalState (runReaderT (runDelayedIO' x) req) s) - restoreM = DelayedIO . lift . withInternalState . const . restoreM - - -runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) -runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req - --- | A 'Delayed' without any stored checks. -emptyDelayed :: RouteResult a -> Delayed env a -emptyDelayed result = - Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result) - where - r = return () - --- | Fail with the option to recover. -delayedFail :: ServantErr -> DelayedIO a -delayedFail err = liftRouteResult $ Fail err - --- | Fail fatally, i.e., without any option to recover. -delayedFailFatal :: ServantErr -> DelayedIO a -delayedFailFatal err = liftRouteResult $ FailFatal err - --- | Gain access to the incoming request. -withRequest :: (Request -> DelayedIO a) -> DelayedIO a -withRequest f = do - req <- ask - f req - --- | Add a capture to the end of the capture block. -addCapture :: Delayed env (a -> b) - -> (captured -> DelayedIO a) - -> Delayed (captured, env) b -addCapture Delayed{..} new = - Delayed - { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt - , serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req - , .. - } -- Note [Existential Record Update] - --- | Add a parameter check to the end of the params block -addParameterCheck :: Delayed env (a -> b) - -> DelayedIO a - -> Delayed env b -addParameterCheck Delayed {..} new = - Delayed - { paramsD = (,) <$> paramsD <*> new - , serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req - , .. - } - --- | Add a parameter check to the end of the params block -addHeaderCheck :: Delayed env (a -> b) - -> DelayedIO a - -> Delayed env b -addHeaderCheck Delayed {..} new = - Delayed - { headersD = (,) <$> headersD <*> new - , serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req - , .. - } - --- | Add a method check to the end of the method block. -addMethodCheck :: Delayed env a - -> DelayedIO () - -> Delayed env a -addMethodCheck Delayed{..} new = - Delayed - { methodD = methodD <* new - , .. - } -- Note [Existential Record Update] - --- | Add an auth check to the end of the auth block. -addAuthCheck :: Delayed env (a -> b) - -> DelayedIO a - -> Delayed env b -addAuthCheck Delayed{..} new = - Delayed - { authD = (,) <$> authD <*> new - , serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req - , .. - } -- Note [Existential Record Update] - --- | Add a content type and body checks around parameter checks. --- --- We'll report failed content type check (415), before trying to parse --- query parameters (400). Which, in turn, happens before request body parsing. -addBodyCheck :: Delayed env (a -> b) - -> DelayedIO c -- ^ content type check - -> (c -> DelayedIO a) -- ^ body check - -> Delayed env b -addBodyCheck Delayed{..} newContentD newBodyD = - Delayed - { contentD = (,) <$> contentD <*> newContentD - , bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c - , serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req - , .. - } -- Note [Existential Record Update] - - --- | Add an accept header check before handling parameters. --- In principle, we'd like --- to take a bad body (400) response take precedence over a --- failed accept check (406). BUT to allow streaming the body, --- we cannot run the body check and then still backtrack. --- We therefore do the accept check before the body check, --- when we can still backtrack. There are other solutions to --- this, but they'd be more complicated (such as delaying the --- body check further so that it can still be run in a situation --- where we'd otherwise report 406). -addAcceptCheck :: Delayed env a - -> DelayedIO () - -> Delayed env a -addAcceptCheck Delayed{..} new = - Delayed - { acceptD = acceptD *> new - , .. - } -- Note [Existential Record Update] - --- | Many combinators extract information that is passed to --- the handler without the possibility of failure. In such a --- case, 'passToServer' can be used. -passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b -passToServer Delayed{..} x = - Delayed - { serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req - , .. - } -- Note [Existential Record Update] - --- | Run a delayed server. Performs all scheduled operations --- in order, and passes the results from the capture and body --- blocks on to the actual handler. --- --- This should only be called once per request; otherwise the guarantees about --- effect and HTTP error ordering break down. -runDelayed :: Delayed env a - -> env - -> Request - -> ResourceT IO (RouteResult a) -runDelayed Delayed{..} env = runDelayedIO $ do - r <- ask - c <- capturesD env - methodD - a <- authD - acceptD - content <- contentD - p <- paramsD -- Has to be before body parsing, but after content-type checks - h <- headersD - b <- bodyD content - liftRouteResult (serverD c p h a b r) - --- | Runs a delayed server and the resulting action. --- Takes a continuation that lets us send a response. --- Also takes a continuation for how to turn the --- result of the delayed server into a response. -runAction :: Delayed env (Handler a) - -> env - -> Request - -> (RouteResult Response -> IO r) - -> (a -> RouteResult Response) - -> IO r -runAction action env req respond k = runResourceT $ - runDelayed action env req >>= go >>= liftIO . respond - where - go (Fail e) = return $ Fail e - go (FailFatal e) = return $ FailFatal e - go (Route a) = liftIO $ do - e <- runHandler a - case e of - Left err -> return . Route $ responseServantErr err - Right x -> return $! k x - -{- Note [Existential Record Update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Due to GHC issue , we cannot -do the more succint thing - just update the records we actually change. --} diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs deleted file mode 100644 --- a/src/Servant/Server/Internal/ServantErr.hs +++ /dev/null @@ -1,472 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Servant.Server.Internal.ServantErr where - -import Control.Exception (Exception) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Typeable (Typeable) -import qualified Network.HTTP.Types as HTTP -import Network.Wai (Response, responseLBS) - -data ServantErr = ServantErr { errHTTPCode :: Int - , errReasonPhrase :: String - , errBody :: LBS.ByteString - , errHeaders :: [HTTP.Header] - } deriving (Show, Eq, Read, Typeable) - -instance Exception ServantErr - -responseServantErr :: ServantErr -> Response -responseServantErr ServantErr{..} = responseLBS status errHeaders errBody - where - status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) - --- | 'err300' Multiple Choices --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err300 { errBody = "I can't choose." } --- -err300 :: ServantErr -err300 = ServantErr { errHTTPCode = 300 - , errReasonPhrase = "Multiple Choices" - , errBody = "" - , errHeaders = [] - } - --- | 'err301' Moved Permanently --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err301 --- -err301 :: ServantErr -err301 = ServantErr { errHTTPCode = 301 - , errReasonPhrase = "Moved Permanently" - , errBody = "" - , errHeaders = [] - } - --- | 'err302' Found --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err302 --- -err302 :: ServantErr -err302 = ServantErr { errHTTPCode = 302 - , errReasonPhrase = "Found" - , errBody = "" - , errHeaders = [] - } - --- | 'err303' See Other --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err303 --- -err303 :: ServantErr -err303 = ServantErr { errHTTPCode = 303 - , errReasonPhrase = "See Other" - , errBody = "" - , errHeaders = [] - } - --- | 'err304' Not Modified --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err304 --- -err304 :: ServantErr -err304 = ServantErr { errHTTPCode = 304 - , errReasonPhrase = "Not Modified" - , errBody = "" - , errHeaders = [] - } - --- | 'err305' Use Proxy --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err305 --- -err305 :: ServantErr -err305 = ServantErr { errHTTPCode = 305 - , errReasonPhrase = "Use Proxy" - , errBody = "" - , errHeaders = [] - } - --- | 'err307' Temporary Redirect --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err307 --- -err307 :: ServantErr -err307 = ServantErr { errHTTPCode = 307 - , errReasonPhrase = "Temporary Redirect" - , errBody = "" - , errHeaders = [] - } - --- | 'err400' Bad Request --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } --- -err400 :: ServantErr -err400 = ServantErr { errHTTPCode = 400 - , errReasonPhrase = "Bad Request" - , errBody = "" - , errHeaders = [] - } - --- | 'err401' Unauthorized --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } --- -err401 :: ServantErr -err401 = ServantErr { errHTTPCode = 401 - , errReasonPhrase = "Unauthorized" - , errBody = "" - , errHeaders = [] - } - --- | 'err402' Payment Required --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } --- -err402 :: ServantErr -err402 = ServantErr { errHTTPCode = 402 - , errReasonPhrase = "Payment Required" - , errBody = "" - , errHeaders = [] - } - --- | 'err403' Forbidden --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err403 { errBody = "Please login first." } --- -err403 :: ServantErr -err403 = ServantErr { errHTTPCode = 403 - , errReasonPhrase = "Forbidden" - , errBody = "" - , errHeaders = [] - } - --- | 'err404' Not Found --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } --- -err404 :: ServantErr -err404 = ServantErr { errHTTPCode = 404 - , errReasonPhrase = "Not Found" - , errBody = "" - , errHeaders = [] - } - --- | 'err405' Method Not Allowed --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } --- -err405 :: ServantErr -err405 = ServantErr { errHTTPCode = 405 - , errReasonPhrase = "Method Not Allowed" - , errBody = "" - , errHeaders = [] - } - --- | 'err406' Not Acceptable --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err406 --- -err406 :: ServantErr -err406 = ServantErr { errHTTPCode = 406 - , errReasonPhrase = "Not Acceptable" - , errBody = "" - , errHeaders = [] - } - --- | 'err407' Proxy Authentication Required --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err407 --- -err407 :: ServantErr -err407 = ServantErr { errHTTPCode = 407 - , errReasonPhrase = "Proxy Authentication Required" - , errBody = "" - , errHeaders = [] - } - --- | 'err409' Conflict --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } --- -err409 :: ServantErr -err409 = ServantErr { errHTTPCode = 409 - , errReasonPhrase = "Conflict" - , errBody = "" - , errHeaders = [] - } - --- | 'err410' Gone --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } --- -err410 :: ServantErr -err410 = ServantErr { errHTTPCode = 410 - , errReasonPhrase = "Gone" - , errBody = "" - , errHeaders = [] - } - --- | 'err411' Length Required --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError err411 --- -err411 :: ServantErr -err411 = ServantErr { errHTTPCode = 411 - , errReasonPhrase = "Length Required" - , errBody = "" - , errHeaders = [] - } - --- | 'err412' Precondition Failed --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } --- -err412 :: ServantErr -err412 = ServantErr { errHTTPCode = 412 - , errReasonPhrase = "Precondition Failed" - , errBody = "" - , errHeaders = [] - } - --- | 'err413' Request Entity Too Large --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } --- -err413 :: ServantErr -err413 = ServantErr { errHTTPCode = 413 - , errReasonPhrase = "Request Entity Too Large" - , errBody = "" - , errHeaders = [] - } - --- | 'err414' Request-URI Too Large --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } --- -err414 :: ServantErr -err414 = ServantErr { errHTTPCode = 414 - , errReasonPhrase = "Request-URI Too Large" - , errBody = "" - , errHeaders = [] - } - --- | 'err415' Unsupported Media Type --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } --- -err415 :: ServantErr -err415 = ServantErr { errHTTPCode = 415 - , errReasonPhrase = "Unsupported Media Type" - , errBody = "" - , errHeaders = [] - } - --- | 'err416' Request range not satisfiable --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } --- -err416 :: ServantErr -err416 = ServantErr { errHTTPCode = 416 - , errReasonPhrase = "Request range not satisfiable" - , errBody = "" - , errHeaders = [] - } - --- | 'err417' Expectation Failed --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } --- -err417 :: ServantErr -err417 = ServantErr { errHTTPCode = 417 - , errReasonPhrase = "Expectation Failed" - , errBody = "" - , errHeaders = [] - } - --- | 'err418' Expectation Failed --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." } --- -err418 :: ServantErr -err418 = ServantErr { errHTTPCode = 418 - , errReasonPhrase = "I'm a teapot" - , errBody = "" - , errHeaders = [] - } - --- | 'err422' Unprocessable Entity --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." } --- -err422 :: ServantErr -err422 = ServantErr { errHTTPCode = 422 - , errReasonPhrase = "Unprocessable Entity" - , errBody = "" - , errHeaders = [] - } - --- | 'err500' Internal Server Error --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } --- -err500 :: ServantErr -err500 = ServantErr { errHTTPCode = 500 - , errReasonPhrase = "Internal Server Error" - , errBody = "" - , errHeaders = [] - } - --- | 'err501' Not Implemented --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } --- -err501 :: ServantErr -err501 = ServantErr { errHTTPCode = 501 - , errReasonPhrase = "Not Implemented" - , errBody = "" - , errHeaders = [] - } - --- | 'err502' Bad Gateway --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } --- -err502 :: ServantErr -err502 = ServantErr { errHTTPCode = 502 - , errReasonPhrase = "Bad Gateway" - , errBody = "" - , errHeaders = [] - } - --- | 'err503' Service Unavailable --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } --- -err503 :: ServantErr -err503 = ServantErr { errHTTPCode = 503 - , errReasonPhrase = "Service Unavailable" - , errBody = "" - , errHeaders = [] - } - --- | 'err504' Gateway Time-out --- --- Example: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } --- -err504 :: ServantErr -err504 = ServantErr { errHTTPCode = 504 - , errReasonPhrase = "Gateway Time-out" - , errBody = "" - , errHeaders = [] - } - --- | 'err505' HTTP Version not supported --- --- Example usage: --- --- > failingHandler :: Handler () --- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } --- -err505 :: ServantErr -err505 = ServantErr { errHTTPCode = 505 - , errReasonPhrase = "HTTP Version not supported" - , errBody = "" - , errHeaders = [] - } diff --git a/src/Servant/Server/Internal/ServerError.hs b/src/Servant/Server/Internal/ServerError.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ServerError.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Servant.Server.Internal.ServerError where + +import Control.Exception + (Exception) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Typeable + (Typeable) +import qualified Network.HTTP.Types as HTTP +import Network.Wai + (Response, responseLBS) + +data ServerError = ServerError + { errHTTPCode :: Int + , errReasonPhrase :: String + , errBody :: LBS.ByteString + , errHeaders :: [HTTP.Header] + } + deriving (Show, Eq, Read, Typeable) + +instance Exception ServerError + +responseServerError :: ServerError -> Response +responseServerError ServerError{..} = responseLBS status errHeaders errBody + where + status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) + +-- | 'err300' Multiple Choices +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err300 { errBody = "I can't choose." } +-- +err300 :: ServerError +err300 = ServerError { errHTTPCode = 300 + , errReasonPhrase = "Multiple Choices" + , errBody = "" + , errHeaders = [] + } + +-- | 'err301' Moved Permanently +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err301 +-- +err301 :: ServerError +err301 = ServerError { errHTTPCode = 301 + , errReasonPhrase = "Moved Permanently" + , errBody = "" + , errHeaders = [] + } + +-- | 'err302' Found +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err302 +-- +err302 :: ServerError +err302 = ServerError { errHTTPCode = 302 + , errReasonPhrase = "Found" + , errBody = "" + , errHeaders = [] + } + +-- | 'err303' See Other +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err303 +-- +err303 :: ServerError +err303 = ServerError { errHTTPCode = 303 + , errReasonPhrase = "See Other" + , errBody = "" + , errHeaders = [] + } + +-- | 'err304' Not Modified +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err304 +-- +err304 :: ServerError +err304 = ServerError { errHTTPCode = 304 + , errReasonPhrase = "Not Modified" + , errBody = "" + , errHeaders = [] + } + +-- | 'err305' Use Proxy +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err305 +-- +err305 :: ServerError +err305 = ServerError { errHTTPCode = 305 + , errReasonPhrase = "Use Proxy" + , errBody = "" + , errHeaders = [] + } + +-- | 'err307' Temporary Redirect +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err307 +-- +err307 :: ServerError +err307 = ServerError { errHTTPCode = 307 + , errReasonPhrase = "Temporary Redirect" + , errBody = "" + , errHeaders = [] + } + +-- | 'err400' Bad Request +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err400 { errBody = "Your request makes no sense to me." } +-- +err400 :: ServerError +err400 = ServerError { errHTTPCode = 400 + , errReasonPhrase = "Bad Request" + , errBody = "" + , errHeaders = [] + } + +-- | 'err401' Unauthorized +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err401 { errBody = "Your credentials are invalid." } +-- +err401 :: ServerError +err401 = ServerError { errHTTPCode = 401 + , errReasonPhrase = "Unauthorized" + , errBody = "" + , errHeaders = [] + } + +-- | 'err402' Payment Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err402 { errBody = "You have 0 credits. Please give me $$$." } +-- +err402 :: ServerError +err402 = ServerError { errHTTPCode = 402 + , errReasonPhrase = "Payment Required" + , errBody = "" + , errHeaders = [] + } + +-- | 'err403' Forbidden +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err403 { errBody = "Please login first." } +-- +err403 :: ServerError +err403 = ServerError { errHTTPCode = 403 + , errReasonPhrase = "Forbidden" + , errBody = "" + , errHeaders = [] + } + +-- | 'err404' Not Found +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" } +-- +err404 :: ServerError +err404 = ServerError { errHTTPCode = 404 + , errReasonPhrase = "Not Found" + , errBody = "" + , errHeaders = [] + } + +-- | 'err405' Method Not Allowed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } +-- +err405 :: ServerError +err405 = ServerError { errHTTPCode = 405 + , errReasonPhrase = "Method Not Allowed" + , errBody = "" + , errHeaders = [] + } + +-- | 'err406' Not Acceptable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err406 +-- +err406 :: ServerError +err406 = ServerError { errHTTPCode = 406 + , errReasonPhrase = "Not Acceptable" + , errBody = "" + , errHeaders = [] + } + +-- | 'err407' Proxy Authentication Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err407 +-- +err407 :: ServerError +err407 = ServerError { errHTTPCode = 407 + , errReasonPhrase = "Proxy Authentication Required" + , errBody = "" + , errHeaders = [] + } + +-- | 'err409' Conflict +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } +-- +err409 :: ServerError +err409 = ServerError { errHTTPCode = 409 + , errReasonPhrase = "Conflict" + , errBody = "" + , errHeaders = [] + } + +-- | 'err410' Gone +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } +-- +err410 :: ServerError +err410 = ServerError { errHTTPCode = 410 + , errReasonPhrase = "Gone" + , errBody = "" + , errHeaders = [] + } + +-- | 'err411' Length Required +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError err411 +-- +err411 :: ServerError +err411 = ServerError { errHTTPCode = 411 + , errReasonPhrase = "Length Required" + , errBody = "" + , errHeaders = [] + } + +-- | 'err412' Precondition Failed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } +-- +err412 :: ServerError +err412 = ServerError { errHTTPCode = 412 + , errReasonPhrase = "Precondition Failed" + , errBody = "" + , errHeaders = [] + } + +-- | 'err413' Request Entity Too Large +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err413 { errBody = "Request exceeded 64k." } +-- +err413 :: ServerError +err413 = ServerError { errHTTPCode = 413 + , errReasonPhrase = "Request Entity Too Large" + , errBody = "" + , errHeaders = [] + } + +-- | 'err414' Request-URI Too Large +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err414 { errBody = "Maximum length is 64." } +-- +err414 :: ServerError +err414 = ServerError { errHTTPCode = 414 + , errReasonPhrase = "Request-URI Too Large" + , errBody = "" + , errHeaders = [] + } + +-- | 'err415' Unsupported Media Type +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err415 { errBody = "Supported media types: gif, png" } +-- +err415 :: ServerError +err415 = ServerError { errHTTPCode = 415 + , errReasonPhrase = "Unsupported Media Type" + , errBody = "" + , errHeaders = [] + } + +-- | 'err416' Request range not satisfiable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err416 { errBody = "Valid range is [0, 424242]." } +-- +err416 :: ServerError +err416 = ServerError { errHTTPCode = 416 + , errReasonPhrase = "Request range not satisfiable" + , errBody = "" + , errHeaders = [] + } + +-- | 'err417' Expectation Failed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err417 { errBody = "I found a quux in the request. This isn't going to work." } +-- +err417 :: ServerError +err417 = ServerError { errHTTPCode = 417 + , errReasonPhrase = "Expectation Failed" + , errBody = "" + , errHeaders = [] + } + +-- | 'err418' Expectation Failed +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err418 { errBody = "Apologies, this is not a webserver but a teapot." } +-- +err418 :: ServerError +err418 = ServerError { errHTTPCode = 418 + , errReasonPhrase = "I'm a teapot" + , errBody = "" + , errHeaders = [] + } + +-- | 'err422' Unprocessable Entity +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err422 { errBody = "I understood your request, but can't process it." } +-- +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 = [] + } + +-- | 'err500' Internal Server Error +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- +err500 :: ServerError +err500 = ServerError { errHTTPCode = 500 + , errReasonPhrase = "Internal Server Error" + , errBody = "" + , errHeaders = [] + } + +-- | 'err501' Not Implemented +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err501 { errBody = "/v1/foo is not supported with quux in the request." } +-- +err501 :: ServerError +err501 = ServerError { errHTTPCode = 501 + , errReasonPhrase = "Not Implemented" + , errBody = "" + , errHeaders = [] + } + +-- | 'err502' Bad Gateway +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } +-- +err502 :: ServerError +err502 = ServerError { errHTTPCode = 502 + , errReasonPhrase = "Bad Gateway" + , errBody = "" + , errHeaders = [] + } + +-- | 'err503' Service Unavailable +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err503 { errBody = "We're rewriting in PHP." } +-- +err503 :: ServerError +err503 = ServerError { errHTTPCode = 503 + , errReasonPhrase = "Service Unavailable" + , errBody = "" + , errHeaders = [] + } + +-- | 'err504' Gateway Time-out +-- +-- Example: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } +-- +err504 :: ServerError +err504 = ServerError { errHTTPCode = 504 + , errReasonPhrase = "Gateway Time-out" + , errBody = "" + , errHeaders = [] + } + +-- | 'err505' HTTP Version not supported +-- +-- Example usage: +-- +-- > failingHandler :: Handler () +-- > failingHandler = throwError $ err505 { errBody = "I support HTTP/4.0 only." } +-- +err505 :: ServerError +err505 = ServerError { errHTTPCode = 505 + , errReasonPhrase = "HTTP Version not supported" + , errBody = "" + , errHeaders = [] + } diff --git a/src/Servant/Server/StaticFiles.hs b/src/Servant/Server/StaticFiles.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/StaticFiles.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +-- | This module defines server-side handlers that lets you serve static files. +-- +-- The most common needs for a web application are covered by +-- 'serveDirectoryWebApp`, but the other variants allow you to use +-- different `StaticSettings` and 'serveDirectoryWith' even allows you +-- to specify arbitrary 'StaticSettings' to be used for serving static files. +module Servant.Server.StaticFiles + ( serveDirectoryWebApp + , serveDirectoryWebAppLookup + , serveDirectoryFileServer + , serveDirectoryEmbedded + , serveDirectoryWith + , -- * Deprecated + serveDirectory + ) where + +import Data.ByteString + (ByteString) +import Network.Wai.Application.Static +import Servant.API.Raw + (Raw) +import Servant.Server + (ServerT, Tagged (..)) +import System.FilePath + (addTrailingPathSeparator) +import WaiAppStatic.Storage.Filesystem + (ETagLookup) + +-- | Serve anything under the specified directory as a 'Raw' endpoint. +-- +-- @ +-- type MyApi = "static" :> Raw +-- +-- server :: Server MyApi +-- server = serveDirectoryWebApp "\/var\/www" +-- @ +-- +-- would capture any request to @\/static\/\@ and look for +-- @\@ under @\/var\/www@. +-- +-- It will do its best to guess the MIME type for that file, based on the extension, +-- and send an appropriate /Content-Type/ header if possible. +-- +-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API +-- as a webapp backend, you will most likely not want the static files to be hidden +-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp' +-- handler in the last position, because /servant/ will try to match the handlers +-- in order. +-- +-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. +serveDirectoryWebApp :: FilePath -> ServerT Raw m +serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath + +-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. +serveDirectoryFileServer :: FilePath -> ServerT Raw m +serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath + +-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. +serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m +serveDirectoryWebAppLookup etag = + serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath + +-- | Uses 'embeddedSettings'. +serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m +serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) + +-- | Alias for 'staticApp'. Lets you serve a directory +-- with arbitrary 'StaticSettings'. Useful when you want +-- particular settings not covered by the four other +-- variants. This is the most flexible method. +serveDirectoryWith :: StaticSettings -> ServerT Raw m +serveDirectoryWith = Tagged . staticApp + +-- | Same as 'serveDirectoryFileServer'. It used to be the only +-- file serving function in servant pre-0.10 and will be kept +-- around for a few versions, but is deprecated. +serveDirectory :: FilePath -> ServerT Raw m +serveDirectory = serveDirectoryFileServer +{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} + +fixPath :: FilePath -> FilePath +fixPath = addTrailingPathSeparator 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/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -1,86 +1,6 @@ -{-# LANGUAGE CPP #-} --- | This module defines server-side handlers that lets you serve static files. --- --- The most common needs for a web application are covered by --- 'serveDirectoryWebApp`, but the other variants allow you to use --- different `StaticSettings` and 'serveDirectoryWith' even allows you --- to specify arbitrary 'StaticSettings' to be used for serving static files. module Servant.Utils.StaticFiles - ( serveDirectoryWebApp - , serveDirectoryWebAppLookup - , serveDirectoryFileServer - , serveDirectoryEmbedded - , serveDirectoryWith - , -- * Deprecated - serveDirectory - ) where - -import Data.ByteString (ByteString) -import Network.Wai.Application.Static -import Servant.API.Raw (Raw) -import Servant.Server (Server, Tagged (..)) -import System.FilePath (addTrailingPathSeparator) -#if !MIN_VERSION_wai_app_static(3,1,0) -import Filesystem.Path.CurrentOS (decodeString) -#endif -import WaiAppStatic.Storage.Filesystem (ETagLookup) - --- | Serve anything under the specified directory as a 'Raw' endpoint. --- --- @ --- type MyApi = "static" :> Raw --- --- server :: Server MyApi --- server = serveDirectoryWebApp "\/var\/www" --- @ --- --- would capture any request to @\/static\/\@ and look for --- @\@ under @\/var\/www@. --- --- It will do its best to guess the MIME type for that file, based on the extension, --- and send an appropriate /Content-Type/ header if possible. --- --- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API --- as a webapp backend, you will most likely not want the static files to be hidden --- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp' --- handler in the last position, because /servant/ will try to match the handlers --- in order. --- --- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. -serveDirectoryWebApp :: FilePath -> Server Raw -serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath - --- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. -serveDirectoryFileServer :: FilePath -> Server Raw -serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath - --- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. -serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw -serveDirectoryWebAppLookup etag = - serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath - --- | Uses 'embeddedSettings'. -serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw -serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) - --- | Alias for 'staticApp'. Lets you serve a directory --- with arbitrary 'StaticSettings'. Useful when you want --- particular settings not covered by the four other --- variants. This is the most flexible method. -serveDirectoryWith :: StaticSettings -> Server Raw -serveDirectoryWith = Tagged . staticApp - --- | Same as 'serveDirectoryFileServer'. It used to be the only --- file serving function in servant pre-0.10 and will be kept --- around for a few versions, but is deprecated. -serveDirectory :: FilePath -> Server Raw -serveDirectory = serveDirectoryFileServer -{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} + {-# DEPRECATED "Use Servant.Server.StaticFiles." #-} + ( module Servant.Server.StaticFiles ) + where -fixPath :: FilePath -> FilePath -fixPath = -#if MIN_VERSION_wai_app_static(3,1,0) - addTrailingPathSeparator -#else - decodeString . addTrailingPathSeparator -#endif +import Servant.Server.StaticFiles diff --git a/test/Servant/ArbitraryMonadServerSpec.hs b/test/Servant/ArbitraryMonadServerSpec.hs --- a/test/Servant/ArbitraryMonadServerSpec.hs +++ b/test/Servant/ArbitraryMonadServerSpec.hs @@ -9,9 +9,10 @@ import Servant.API import Servant.Server -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Wai (get, matchStatus, post, - shouldRespondWith, with) +import Test.Hspec + (Spec, describe, it) +import Test.Hspec.Wai + (get, matchStatus, post, shouldRespondWith, with) spec :: Spec spec = describe "Arbitrary monad server" $ do diff --git a/test/Servant/HoistSpec.hs b/test/Servant/HoistSpec.hs --- a/test/Servant/HoistSpec.hs +++ b/test/Servant/HoistSpec.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module Servant.HoistSpec where -import Test.Hspec (Spec) +import Test.Hspec + (Spec) -import Servant +import Servant ------------------------------------------------------------------------------- -- https://github.com/haskell-servant/servant/issues/734 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 @@ -6,16 +6,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where -import Control.Monad (when) -import Data.Aeson (encode) +import Control.Monad + (when) +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, methodPut) -import Safe (readMay) +import Network.HTTP.Types + (hAccept, hAuthorization, hContentType, methodGet, methodPost, + methodPut) +import Safe + (readMay) import Test.Hspec import Test.Hspec.Wai @@ -27,6 +29,7 @@ prioErrorsSpec errorRetrySpec errorChoiceSpec + customFormattersSpec -- * Auth machinery (reused throughout) @@ -247,6 +250,8 @@ :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5 + :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6 + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy @@ -256,8 +261,8 @@ :<|> return 1 :<|> return 2 :<|> (\_ -> return 3) - :<|> (\_ -> return 4) - :<|> (\_ -> return 5) + :<|> ((\_ -> return 4) :<|> (\_ -> return 5)) + :<|> ((\_ -> return 6) :<|> (\_ -> return 7)) errorChoiceSpec :: Spec @@ -278,15 +283,77 @@ request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), (hAccept, "blah")] "5" `shouldRespondWith` 406 + it "should respond with 415 only if none of the subservers supports the request's content type" $ do + request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/json")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/not-supported")] "" + `shouldRespondWith` 415 -- }}} ------------------------------------------------------------------------------ +-- * 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,10 +1,13 @@ {-# 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 (Proxy (..)) -import Test.Hspec (Spec, describe, it, shouldBe, context) -import Test.ShouldNotTypecheck (shouldNotTypecheck) +import Data.Proxy + (Proxy (..)) +import Test.Hspec + (Spec, context, describe, it, shouldBe) +import Test.ShouldNotTypecheck + (shouldNotTypecheck) import Servant.API import Servant.Server.Internal.Context 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 @@ -1,31 +1,37 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.RoutingApplicationSpec (spec) where -import Prelude () -import Prelude.Compat +import Prelude () +import Prelude.Compat -import Control.Exception hiding (Handler) -import Control.Monad.Trans.Resource (register) -import Control.Monad.IO.Class -import Data.IORef -import Data.Proxy -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) -import Servant -import Servant.Server.Internal.RoutingApplication -import Network.Wai (defaultRequest) -import Test.Hspec -import Test.Hspec.Wai (request, shouldRespondWith, with) +import Control.Exception hiding + (Handler) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource + (register) +import Data.IORef +import Data.Proxy +import GHC.TypeLits + (KnownSymbol, Symbol, symbolVal) +import Network.Wai + (defaultRequest) +import Servant +import Servant.Server.Internal +import Test.Hspec +import Test.Hspec.Wai + (request, shouldRespondWith, with) -import qualified Data.Text as T +import qualified Data.Text as T -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe + (unsafePerformIO) data TestResource x = TestResourceNone 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 @@ -1,43 +1,81 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.RouterSpec (spec) where -import Control.Monad (unless) -import Data.Proxy (Proxy(..)) -import Data.Text (unpack) -import Network.HTTP.Types (Status (..)) -import Network.Wai (responseBuilder) -import Network.Wai.Internal (Response (ResponseBuilder)) -import Test.Hspec -import Test.Hspec.Wai (get, shouldRespondWith, with) +import Control.Monad + (unless) +import Data.Proxy + (Proxy (..)) +import Data.Text + (Text, unpack) +import Data.Typeable + (typeRep) +import Network.HTTP.Types + (Status (..)) +import Network.Wai + (responseBuilder) +import Network.Wai.Internal + (Response (ResponseBuilder)) import Servant.API import Servant.Server import Servant.Server.Internal +import Test.Hspec +import Test.Hspec.Wai + (get, shouldRespondWith, with) spec :: Spec spec = describe "Servant.Server.Internal.Router" $ do routerSpec distributivitySpec + serverLayoutSpec routerSpec :: Spec routerSpec = do - let app' :: Application - app' = toApplication $ runRouter router' + describe "tweakResponse" $ do + let app' :: Application + app' = toApplication $ runRouter (const err404) router' - router', router :: Router () - router' = tweakResponse (fmap twk) router - router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + router', router :: Router () + router' = tweakResponse (fmap twk) router + router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - twk :: Response -> Response - twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b - twk b = b + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b - describe "tweakResponse" . with (return app') $ do - it "calls f on route result" $ do - get "" `shouldRespondWith` 202 + with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + describe "runRouter" $ do + let toApp :: Router () -> Application + toApp = toApplication . runRouter (const err404) + + cap :: Router () + cap = CaptureRouter [hint] $ + let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400) + in leafRouter + $ \env req res -> + runAction delayed env req res + . const + $ Route success + + hint :: CaptureHint + hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ()) + + router :: Router () + router = leafRouter (\_ _ res -> res $ Route success) + `Choice` cap + + success :: Response + success = responseBuilder (Status 200 "") [] "" + + with (pure $ toApp router) $ do + it "capture failure returns a 400 response" $ do + get "/badcapture" `shouldRespondWith` 400 + distributivitySpec :: Spec distributivitySpec = describe "choice" $ do @@ -66,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)) @@ -112,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 @@ -307,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/StaticFilesSpec.hs b/test/Servant/Server/StaticFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/StaticFilesSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Server.StaticFilesSpec where + +import Control.Exception + (bracket) +import Data.Proxy + (Proxy (Proxy)) +import Network.Wai + (Application) +import System.Directory + (createDirectory, getCurrentDirectory, setCurrentDirectory) +import System.IO.Temp + (withSystemTempDirectory) +import Test.Hspec + (Spec, around_, describe, it) +import Test.Hspec.Wai + (get, shouldRespondWith, with) + +import Servant.API + ((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Raw) +import Servant.Server + (Server, serve) +import Servant.Server.StaticFiles + (serveDirectoryFileServer) +import Servant.ServerSpec + (Person (Person)) + +type Api = + "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person + :<|> "static" :> Raw + + +api :: Proxy Api +api = Proxy + +app :: Application +app = serve api server + +server :: Server Api +server = + (\ name_ -> return (Person name_ 42)) + :<|> serveDirectoryFileServer "static" + +withStaticFiles :: IO () -> IO () +withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> + bracket (setup tmpDir) teardown (const action) + where + setup tmpDir = do + outer <- getCurrentDirectory + setCurrentDirectory tmpDir + createDirectory "static" + writeFile "static/foo.txt" "bar" + writeFile "static/index.html" "index" + return outer + + teardown outer = do + setCurrentDirectory outer + +spec :: Spec +spec = do + around_ withStaticFiles $ with (return app) $ do + describe "serveDirectory" $ do + it "successfully serves files" $ do + get "/static/foo.txt" `shouldRespondWith` "bar" + + it "serves the contents of index.html when requesting the root of a directory" $ do + get "/static/" `shouldRespondWith` "index" 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 @@ -1,18 +1,19 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} -- | This module tests whether streaming works from client to server -- with a server implemented with servant-server. module Servant.Server.StreamingSpec where import Control.Concurrent -import Control.Exception hiding (Handler) +import Control.Exception hiding + (Handler) import Control.Monad.IO.Class -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy import Network.HTTP.Types import Network.Wai import Network.Wai.Internal @@ -80,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.hs b/test/Servant/Server/UsingContextSpec.hs --- a/test/Servant/Server/UsingContextSpec.hs +++ b/test/Servant/Server/UsingContextSpec.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.UsingContextSpec where import Network.Wai -import Test.Hspec (Spec, describe, it) +import Test.Hspec + (Spec, describe, it) import Test.Hspec.Wai import Servant 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 @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | These are custom combinators for Servant.Server.UsingContextSpec. -- @@ -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,94 +1,120 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 800 +{-# 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 #-} -#else -{-# OPTIONS_GHC -fcontext-stack=100 #-} -#endif module Servant.ServerSpec where -import Control.Monad (forM_, when, unless) -import Control.Monad.Error.Class (MonadError (..)) -import Data.Aeson (FromJSON, ToJSON, decode', encode) -import qualified Data.ByteString.Base64 as Base64 -import Data.Char (toUpper) -import Data.Monoid -import Data.Proxy (Proxy (Proxy)) -import Data.String (fromString) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Network.HTTP.Types (Status (..), hAccept, hContentType, - methodDelete, methodGet, - methodHead, methodPatch, - methodPost, methodPut, ok200, - imATeapot418, - parseQuery) -import Network.Wai (Application, Request, requestHeaders, pathInfo, - queryString, rawQueryString, - responseLBS) -import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody, - simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), AuthProtect, - BasicAuth, BasicAuthData(BasicAuthData), - Capture, CaptureAll, Delete, Get, Header, - Headers, HttpVersion, - IsSecure (..), JSON, - NoContent (..), Patch, PlainText, - Post, Put, EmptyAPI, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, - StdMethod (..), Verb, addHeader) -import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (Server, Handler, Tagged (..), err401, err403, - err404, serve, serveWithContext, - Context((:.), EmptyContext), emptyServer) -import Test.Hspec (Spec, context, describe, it, - shouldBe, shouldContain) -import qualified Test.Hspec.Wai as THW -import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, shouldRespondWith, - with, (<:>)) +import Prelude () +import Prelude.Compat -import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), - BasicAuthResult(Authorized,Unauthorized)) +import Control.Monad + (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) +import Data.Maybe + (fromMaybe) +import Data.Proxy + (Proxy (Proxy)) +import Data.String + (fromString) +import qualified Data.Text as T +import GHC.Generics + (Generic) +import Network.HTTP.Types + (QueryItem, Status (..), hAccept, hContentType, imATeapot418, + methodDelete, methodGet, methodHead, methodPatch, methodPost, + methodPut, ok200, parseQuery) +import Network.Wai + (Application, Middleware, Request, pathInfo, queryString, + rawQueryString, requestHeaders, responseLBS) +import Network.Wai.Test + (defaultRequest, request, runSession, simpleBody, + simpleHeaders, simpleStatus) +import Servant.API + ((:<|>) (..), (:>), AuthProtect, BasicAuth, + BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, + 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, 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, 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, matchHeaders, matchStatus, shouldRespondWith, + with, (<:>)) +import qualified Test.Hspec.Wai as THW +import Text.Read (readMaybe) + import Servant.Server.Experimental.Auth - (AuthHandler, AuthServerData, - mkAuthHandler) + (AuthHandler, AuthServerData, mkAuthHandler) +import Servant.Server.Internal.BasicAuth + (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult (Authorized, Unauthorized)) import Servant.Server.Internal.Context - (NamedContext(..)) + (NamedContext (..)) -- * comprehensive api test -- 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 @@ -99,12 +125,14 @@ type VerbApi method status = Verb method status '[JSON] Person - :<|> "noContent" :> Verb method status '[JSON] NoContent + :<|> "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 ) + :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -113,7 +141,10 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> return (addHeader' 5 alice) :<|> (return alice :<|> return "B") + :<|> return (S.source ["bytestring"]) + get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -133,7 +164,7 @@ it "returns no content on NoContent" $ do response <- THW.request method "/noContent" [] "" - liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ statusCode (simpleStatus response) `shouldBe` 204 liftIO $ simpleBody response `shouldBe` "" -- HEAD should not return body @@ -142,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" [] "" @@ -155,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 "" @@ -179,6 +212,11 @@ liftIO $ simpleHeaders response `shouldContain` [("Content-Type", "application/json;charset=utf-8")] + it "works for Stream as for Result" $ do + response <- THW.request method "/stream" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "bytestring" + test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210 test "PUT 203" put203 methodPut 203 @@ -192,101 +230,163 @@ ------------------------------------------------------------------------------ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal + :<|> "ears" :> Capture' '[Lenient] "ears" Integer :> Get '[JSON] Animal + :<|> "eyes" :> Capture' '[Strict] "eyes" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> Handler Animal -captureServer legs = case legs of - 4 -> return jerry - 2 -> return tweety - _ -> throwError err404 +captureServer :: Server CaptureApi +captureServer = getLegs :<|> getEars :<|> getEyes + where getLegs :: Integer -> Handler Animal + getLegs legs = case legs of + 4 -> return jerry + 2 -> return tweety + _ -> throwError err404 + + getEars :: Either String Integer -> Handler Animal + getEars (Left _) = return chimera -- ignore integer parse error, return weird animal + getEars (Right 2) = return jerry + getEars (Right _) = throwError err404 + + getEyes :: Integer -> Handler Animal + getEyes 2 = return jerry + 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 - 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])) + 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 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_ 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 @@ -299,123 +399,183 @@ 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 + + queryParamSpec :: Spec queryParamSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + describe "Servant.API.QueryParam" $ do it "allows retrieving simple GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params1 = "?name=bob" - response1 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params1, - queryString = parseQuery params1 - } - liftIO $ do - decode' (simpleBody response1) `shouldBe` Just alice{ - name = "bob" - } + flip runSession (serve queryParamApi qpServer) $ do + response1 <- mkRequest "?name=bob" [] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + { name = "bob" + } it "allows retrieving lists in GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params2 = "?names[]=bob&names[]=john" - response2 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params2, - queryString = parseQuery params2, - pathInfo = ["a"] - } - liftIO $ - decode' (simpleBody response2) `shouldBe` Just alice{ - name = "john" - } + flip runSession (serve queryParamApi qpServer) $ do + response2 <- mkRequest "?names[]=bob&names[]=john" ["a"] + liftIO $ decode' (simpleBody response2) `shouldBe` Just alice + { name = "john" + } it "parses a query parameter" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?age=55" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["param"] - } - liftIO $ - decode' (simpleBody response) `shouldBe` Just alice{ - age = 55 - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=55" ["param"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 55 + } it "generates an error on query parameter parse failure" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?age=foo" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["param"] - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=foo" ["param"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "parses multiple query parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?ages=10&ages=22" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["multiparam"] - } - liftIO $ - decode' (simpleBody response) `shouldBe` Just alice{ - age = 32 - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?ages=10&ages=22" ["multiparam"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 32 + } it "generates an error on parse failures of multiple parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?ages=2&ages=foo" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["multiparam"] - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?ages=2&ages=foo" ["multiparam"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () - it "allows retrieving value-less GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params3 = "?capitalize" - response3 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3, - queryString = parseQuery params3, - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3) `shouldBe` Just alice{ - name = "ALICE" - } + flip runSession (serve queryParamApi qpServer) $ do + response3 <- mkRequest "?capitalize" ["b"] + liftIO $ decode' (simpleBody response3) `shouldBe` Just alice + { name = "ALICE" + } - let params3' = "?capitalize=" - response3' <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3', - queryString = parseQuery params3', - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3') `shouldBe` Just alice{ - name = "ALICE" - } + response3' <- mkRequest "?capitalize=" ["b"] + liftIO $ decode' (simpleBody response3') `shouldBe` Just alice + { name = "ALICE" + } - let params3'' = "?unknown=" - response3'' <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3'', - queryString = parseQuery params3'', - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3'') `shouldBe` Just alice{ - name = "Alice" - } + response3'' <- mkRequest "?unknown=" ["b"] + liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice + { 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 = rewrite <$> queryString req + } + where + rewrite :: QueryItem -> QueryItem + rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v) + + let app = queryRewriter $ serve queryParamApi qpServer + + it "allows rewriting for simple GET/query parameters" $ + flip runSession app $ do + response1 <- mkRequest "?person_name=bob" [] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + { name = "bob" + } + + it "allows rewriting for lists in GET parameters" $ + flip runSession app $ do + response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"] + liftIO $ decode' (simpleBody response2) `shouldBe` Just alice + { name = "john" + } + + it "allows rewriting when parsing multiple query parameters" $ + flip runSession app $ do + response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 32 + } + + it "allows retrieving value-less GET parameters" $ + flip runSession app $ do + response3 <- mkRequest "?person_capitalize" ["b"] + liftIO $ decode' (simpleBody response3) `shouldBe` Just alice + { name = "ALICE" + } + + response3' <- mkRequest "?person_capitalize=" ["b"] + liftIO $ decode' (simpleBody response3') `shouldBe` Just alice + { name = "ALICE" + } + + response3'' <- mkRequest "?person_unknown=" ["b"] + liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice + { name = "Alice" + } + -- }}} ------------------------------------------------------------------------------ +-- * fragmentSpec {{{ +------------------------------------------------------------------------------ + +type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person + :<|> "age" :> Fragment Integer :> Get '[JSON] Person + +fragmentApi :: Proxy FragmentApi +fragmentApi = Proxy + +fragServer :: Server FragmentApi +fragServer = fragmentServer :<|> fragAge + where + fragmentServer = return alice + fragAge = return alice + +fragmentSpec :: Spec +fragmentSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + + describe "Servant.API.Fragment" $ 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 @@ -438,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 -- }}} ------------------------------------------------------------------------------ @@ -499,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 = @@ -547,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 {{{ @@ -583,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 @@ -661,7 +862,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + Tagged (\ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -672,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 -- }}} ------------------------------------------------------------------------------ @@ -706,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") = () @@ -719,23 +916,86 @@ 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 + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ @@ -767,6 +1027,10 @@ tweety :: Animal tweety = Animal "Bird" 2 + +-- weird animal with non-integer amount of ears +chimera :: Animal +chimera = Animal "Chimera" (-1) beholder :: Animal beholder = Animal "Beholder" 0 diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Utils.StaticFilesSpec where - -import Control.Exception (bracket) -import Data.Proxy (Proxy (Proxy)) -import Network.Wai (Application) -import System.Directory (createDirectory, - getCurrentDirectory, - setCurrentDirectory) -import System.IO.Temp (withSystemTempDirectory) -import Test.Hspec (Spec, around_, describe, it) -import Test.Hspec.Wai (get, shouldRespondWith, with) - -import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) -import Servant.Server (Server, serve) -import Servant.ServerSpec (Person (Person)) -import Servant.Utils.StaticFiles (serveDirectoryFileServer) - -type Api = - "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person - :<|> "static" :> Raw - - -api :: Proxy Api -api = Proxy - -app :: Application -app = serve api server - -server :: Server Api -server = - (\ name_ -> return (Person name_ 42)) - :<|> serveDirectoryFileServer "static" - -withStaticFiles :: IO () -> IO () -withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> - bracket (setup tmpDir) teardown (const action) - where - setup tmpDir = do - outer <- getCurrentDirectory - setCurrentDirectory tmpDir - createDirectory "static" - writeFile "static/foo.txt" "bar" - writeFile "static/index.html" "index" - return outer - - teardown outer = do - setCurrentDirectory outer - -spec :: Spec -spec = do - around_ withStaticFiles $ with (return app) $ do - describe "serveDirectory" $ do - it "successfully serves files" $ do - get "/static/foo.txt" `shouldRespondWith` "bar" - - it "serves the contents of index.html when requesting the root of a directory" $ do - get "/static/" `shouldRespondWith` "index" diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources