servant 0.14.1 → 0.15
raw patch · 24 files changed
+1112/−475 lines, 24 filesdep +bifunctorsdep +transformersdep −aeson-compatdep −natural-transformationdep −semigroupsdep ~QuickCheckdep ~aesondep ~basesetup-changed
Dependencies added: bifunctors, transformers
Dependencies removed: aeson-compat, natural-transformation, semigroups
Dependency ranges changed: QuickCheck, aeson, base, base-compat, bytestring, case-insensitive, doctest, hspec, http-api-data, http-media, http-types, mtl, quickcheck-instances, singleton-bool, tagged, vault
Files
- CHANGELOG.md +161/−0
- LICENSE +1/−1
- Setup.hs +33/−0
- Setup.lhs +0/−31
- include/overlapping-compat.h +0/−8
- servant.cabal +57/−48
- src/Servant/API.hs +8/−9
- src/Servant/API/Alternative.hs +22/−0
- src/Servant/API/ContentTypes.hs +8/−16
- src/Servant/API/Internal/Test/ComprehensiveAPI.hs +5/−47
- src/Servant/API/ResponseHeaders.hs +43/−6
- src/Servant/API/Stream.hs +194/−98
- src/Servant/API/TypeLevel.hs +0/−15
- src/Servant/API/Verbs.hs +4/−1
- src/Servant/Links.hs +5/−1
- src/Servant/Test/ComprehensiveAPI.hs +78/−0
- src/Servant/Types/SourceT.hs +349/−0
- src/Servant/Utils/Enter.hs +0/−122
- test/Servant/API/ContentTypesSpec.hs +23/−18
- test/Servant/API/ResponseHeadersSpec.hs +4/−4
- test/Servant/API/StreamSpec.hs +99/−0
- test/Servant/LinksSpec.hs +13/−14
- test/Servant/Utils/EnterSpec.hs +0/−33
- test/doctests.hs +5/−3
CHANGELOG.md view
@@ -1,5 +1,165 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.15+----++### Significant changes++- 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.++- *servant-client* Separate streaming client.+ [#1066](https://github.com/haskell-servant/servant/pull/1066)++ We now have two `http-client` based clients,+ in `Servant.Client` and `Servant.Client.Streaming`.++ Their API is the same, except for+ - `Servant.Client` **cannot** request `Stream` endpoints.+ - `Servant.Client` is *run* by direct+ `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)`+ - `Servant.Client.Streaming` **can** request `Stream` endpoints.+ - `Servant.Client.Streaming` is *used* by CPSised+ `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b`++ To access `Stream` endpoints use `Servant.Client.Streaming` with+ `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`.+ You can use both too, `ClientEnv` and `BaseUrl` types are same for both.++ **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints.+ Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until+ the whole response is received.++ There is `Servant.Client.Streaming.runClientM` function, but it has+ restricted type. `NFData a` constraint prevents using it with+ `SourceT`, `Conduit` etc. response types.++ ```haskell+ runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a)+ ```++ This change shouldn't affect you, if you don't use streaming endpoints.++- *servant-client-core* Related to the previous:+ `streamingResponse` is removed from `RunClient`.+ We have a new type-class:++ ```haskell+ class RunClient m => RunStreamingClient m where+ withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a+ ```++- 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* `ComprehensiveAPI` is a part of public API in `Servant.Test.ComprehensiveAPI` module.+ This API type is used to verify that libraries implement all core combinators.+ Now we won't change this type between major versions.+ (This has been true for some time already).+ [#1070](https://github.com/haskell-servant/servant/pull/1070)++- *servant* Remove `Servant.Utils.Enter` module+ (deprecated in `servant-0.12` in favour of `hoistServer`)+ [#996](https://github.com/haskell-servant/servant/pull/996)++- *servant-foreign* Add support so `HasForeign` can be implemented for+ `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart)+ [#1035](https://github.com/haskell-servant/servant/pull/1035)++### Other changes++- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances.+ [#1076](https://github.com/haskell-servant/servant/pull/1076)++- *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-docs* Fix markdown indentation+ [#1043](https://github.com/haskell-servant/servant/pull/1043)++- *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-client-core* Add `aeson` and `Lift BaseUrl` instances+ [#1037](https://github.com/haskell-servant/servant/pull/1037)++- *servant* Add `ToSourceIO (NonEmpty a)` instance+ [#988](https://github.com/haskell-servant/servant/pull/988)++- Development process improvements+ - Apply `stylish-haskell` to all modules+ [#1001](https://github.com/haskell-servant/servant/pull/1001)+ - Amend `CONTRIBUTING.md`+ [#1036](https://github.com/haskell-servant/servant/pull/1036)+ - `servant-docs` has golden tests for `ComprehensiveAPI`+ [#1071](https://github.com/haskell-servant/servant/pull/1071)+ - Other+ [#1039](https://github.com/haskell-servant/servant/pull/1039)+ [#1046](https://github.com/haskell-servant/servant/pull/1046)+ [#1062](https://github.com/haskell-servant/servant/pull/1062)+ [#1069](https://github.com/haskell-servant/servant/pull/1069)+ [#985](https://github.com/haskell-servant/servant/pull/985)++- *Documentation* Tutorial and new recipes+ - [Using free client](https://haskell-servant.readthedocs.io/en/latest/cookbook/using-free-client/UsingFreeClient.html)+ [#1005](https://github.com/haskell-servant/servant/pull/1005)+ - [Generating mock curl calls](https://haskell-servant.readthedocs.io/en/latest/cookbook/curl-mock/CurlMock.html)+ [#1033](https://github.com/haskell-servant/servant/pull/1033)+ - [Error logging with Sentry](https://haskell-servant.readthedocs.io/en/latest/cookbook/sentry/Sentry.html)+ [#987](https://github.com/haskell-servant/servant/pull/987)+ - [Hoist Server With Context for Custom Monads](https://haskell-servant.readthedocs.io/en/latest/cookbook/hoist-server-with-context/HoistServerWithContext.html)+ [#1044](https://github.com/haskell-servant/servant/pull/1044)+ - [How To Test Servant Applications](https://haskell-servant.readthedocs.io/en/latest/cookbook/testing/Testing.html)+ [#1050](https://github.com/haskell-servant/servant/pull/1050)+ - `genericServeT`: using custom monad with `Servant.API.Generic`+ in [Using generics](https://haskell-servant.readthedocs.io/en/latest/cookbook/generic/Generic.html)+ [#1058](https://github.com/haskell-servant/servant/pull/1058)+ - Tutorial+ [#974](https://github.com/haskell-servant/servant/pull/974)+ [#1007](https://github.com/haskell-servant/servant/pull/1007)+ - miscellanea: fixed typos etc.+ [#1030](https://github.com/haskell-servant/servant/pull/1030)+ [#1020](https://github.com/haskell-servant/servant/pull/1020)+ [#1059](https://github.com/haskell-servant/servant/pull/1059)++- *Documentation* README+ [#1010](https://github.com/haskell-servant/servant/pull/1010)++- *servant-client-ghcjs* updates. **note** package is not released on Hackage+ [#938](https://github.com/haskell-servant/servant/pull/938)+ 0.14.1 ------ @@ -10,6 +170,7 @@ and `servant-server` (`Servant.Server.Generic`). - Deprecate `Servant.Utils.Links`, use `Servant.Links`.+ [#998](https://github.com/haskell-servant/servant/pull/998) - *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.
LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# 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+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#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
− Setup.lhs
@@ -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}
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant.cabal view
@@ -1,31 +1,34 @@+cabal-version: >=1.10 name: servant-version: 0.14.1+version: 0.15+ synopsis: A family of combinators for defining webservices APIs+category: Servant, Web description: A family of combinators for defining webservices APIs and serving them . You can learn about the basics in the <http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html tutorial>. . <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG>+ homepage: http://haskell-servant.readthedocs.org/-Bug-reports: http://github.com/haskell-servant/servant/issues+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+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors 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.3+ GHC ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.2+ extra-source-files:- include/*.h CHANGELOG.md+ source-repository head type: git location: http://github.com/haskell-servant/servant.git@@ -49,7 +52,6 @@ Servant.API.Generic Servant.API.Header Servant.API.HttpVersion- Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure Servant.API.Modifiers Servant.API.QueryParam@@ -63,44 +65,58 @@ Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext++ -- Types+ exposed-modules:+ Servant.Types.SourceT++ -- Test stuff+ exposed-modules:+ Servant.Test.ComprehensiveAPI++ -- Safe links+ exposed-modules: Servant.Links -- Deprecated modules, to be removed in late 2019 exposed-modules: Servant.Utils.Links- Servant.Utils.Enter+ Servant.API.Internal.Test.ComprehensiveAPI -- 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- , mtl >= 2.1 && < 2.3- , text >= 1.2.3.0 && < 1.3+ base >= 4.9 && < 4.13+ , bytestring >= 0.10.8.1 && < 0.11+ , mtl >= 2.2.2 && < 2.3+ , transformers >= 0.5.2.0 && < 0.6+ , text >= 1.2.3.0 && < 1.3 - if !impl(ghc >= 8.0)- build-depends:- semigroups >= 0.18.4 && < 0.19 + -- We depend (heavily) on the API of these packages:+ -- i.e. re-export, or allow using without direct dependency+ build-depends:+ http-api-data >= 0.4 && < 0.4.1+ , singleton-bool >= 0.1.4 && < 0.1.5+ -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.1 && < 0.11- , aeson >= 1.3.1.1 && < 1.5+ base-compat >= 0.10.5 && < 0.11+ , aeson >= 1.4.1.0 && < 1.5 , attoparsec >= 0.13.2.2 && < 0.14- , case-insensitive >= 1.2.0.10 && < 1.3- , http-api-data >= 0.3.8.1 && < 0.4- , http-media >= 0.7.1.2 && < 0.8- , http-types >= 0.12.1 && < 0.13- , natural-transformation >= 0.4 && < 0.5+ , bifunctors >= 5.5.3 && < 5.6+ , case-insensitive >= 1.2.0.11 && < 1.3+ , http-media >= 0.7.1.3 && < 0.8+ , http-types >= 0.12.2 && < 0.13 , mmorph >= 1.1.2 && < 1.2- , tagged >= 0.8.5 && < 0.9- , singleton-bool >= 0.1.4 && < 0.2- , string-conversions >= 0.4.0.1 && < 0.5 , network-uri >= 2.6.1.0 && < 2.7- , vault >= 0.3.1.1 && < 0.4+ , QuickCheck >= 2.12.6.1 && <2.13+ , string-conversions >= 0.4.0.1 && < 0.5+ , tagged >= 0.8.6 && < 0.9+ , vault >= 0.3.1.2 && < 0.4 hs-source-dirs: src default-language: Haskell2010@@ -124,10 +140,7 @@ , TypeOperators , TypeSynonymInstances , UndecidableInstances- ghc-options: -Wall- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ ghc-options: -Wall -Wno-redundant-constraints test-suite spec type: exitcode-stdio-1.0@@ -138,7 +151,7 @@ other-modules: Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec- Servant.Utils.EnterSpec+ Servant.API.StreamSpec Servant.LinksSpec -- Dependencies inherited from the library. No need to specify bounds.@@ -147,33 +160,30 @@ , base-compat , aeson , bytestring+ , mtl , servant , string-conversions , text-- if !impl(ghc >= 8.0)- build-depends:- semigroups+ , transformers -- Additonal dependencies build-depends:- aeson-compat >= 0.3.7.1 && < 0.4- , hspec >= 2.5.1 && < 2.6- , QuickCheck >= 2.11.3 && < 2.12- , quickcheck-instances >= 0.3.18 && < 0.4+ hspec >= 2.6.0 && < 2.7+ , QuickCheck >= 2.12.6.1 && < 2.13+ , quickcheck-instances >= 0.3.19 && < 0.4 build-tool-depends:- hspec-discover:hspec-discover >= 2.5.1 && < 2.6+ hspec-discover:hspec-discover >= 2.6.0 && < 2.7 test-suite doctests build-depends: base , servant- , doctest >= 0.15.0 && <0.17+ , doctest >= 0.16.0 && <0.17 -- We test Links failure with doctest, so we need extra dependencies build-depends:- hspec >= 2.5.1 && < 2.6+ hspec >= 2.6.0 && < 2.7 type: exitcode-stdio-1.0 main-is: test/doctests.hs@@ -182,6 +192,5 @@ ghc-options: -Wall -threaded if impl(ghc >= 8.2) x-doctest-options: -fdiagnostics-color=never- include-dirs: include x-doctest-source-dirs: test x-doctest-modules: Servant.LinksSpec
src/Servant/API.hs view
@@ -110,15 +110,14 @@ (ReqBody, ReqBody') import Servant.API.ResponseHeaders (AddHeader, BuildHeadersTo (buildHeadersTo),- GetHeaders (getHeaders), HList (..), Headers (..),- ResponseHeader (..), addHeader, getHeadersHList, getResponse,- noHeader)+ GetHeaders (getHeaders), HList (..), HasResponseHeader,+ Headers (..), ResponseHeader (..), addHeader, getHeadersHList,+ getResponse, lookupResponseHeader, noHeader) import Servant.API.Stream- (BoundaryStrategy (..), BuildFromStream (..),- ByteStringParser (..), FramingRender (..),- FramingUnrender (..), NetstringFraming, NewlineFraming,- NoFraming, ResultStream (..), Stream, StreamGenerator (..),- StreamGet, StreamPost, ToStreamGenerator (..))+ (FramingRender (..), FramingUnrender (..), FromSourceIO (..),+ NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream,+ StreamBody, StreamBody', StreamGet, StreamPost,+ ToSourceIO (..)) import Servant.API.Sub ((:>)) import Servant.API.Vault@@ -130,7 +129,7 @@ Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, Post, PostAccepted, PostCreated, PostNoContent, PostNonAuthoritative, PostResetContent, Put, PutAccepted,- PutNoContent, PutNonAuthoritative,+ PutCreated, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext)
src/Servant/API/Alternative.hs view
@@ -7,6 +7,15 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where +import Control.Applicative (liftA2)+import Data.Biapplicative+ (Biapplicative (..))+import Data.Bifoldable+ (Bifoldable (..))+import Data.Bifunctor+ (Bifunctor (..))+import Data.Bitraversable+ (Bitraversable (..)) import Data.Semigroup (Semigroup (..)) import Data.Typeable@@ -32,6 +41,19 @@ instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b')++instance Bifoldable (:<|>) where+ bifoldMap f g ~(a :<|> b) = f a `mappend` g b++instance Bifunctor (:<|>) where+ bimap f g ~(a :<|> b) = f a :<|> g b++instance Biapplicative (:<|>) where+ bipure = (:<|>)+ (f :<|> g) <<*>> (a :<|> b) = f a :<|> g b++instance Bitraversable (:<|>) where+ bitraverse f g ~(a :<|> b) = liftA2 (:<|>) (f a) (g b) -- $setup -- >>> import Servant.API
src/Servant/API/ContentTypes.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -14,8 +13,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -#include "overlapping-compat.h"- -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from@@ -98,16 +95,13 @@ import Data.Typeable import GHC.Generics (Generic)+import qualified GHC.TypeLits as TL import qualified Network.HTTP.Media as M import Prelude () import Prelude.Compat import Web.FormUrlEncoded (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) -#if MIN_VERSION_base(4,9,0)-import qualified GHC.TypeLits as TL-#endif- -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable@@ -185,18 +179,16 @@ -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} (Accept ct, AllMime cts, AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs -#if MIN_VERSION_base(4,9,0) instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.") => AllCTRender '[] () where handleAcceptH _ _ _ = error "unreachable"-#endif -------------------------------------------------------------------------- -- * Unrender@@ -277,13 +269,13 @@ -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where+instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp where bs = mimeRender pctyp a pctyp = Proxy :: Proxy ctyp -instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where@@ -299,12 +291,12 @@ -- Ideally we would like to declare a 'MimeRender a NoContent' instance, and -- then this would be taken care of. However there is no more specific instance -- between that and 'MimeRender JSON a', so we do this instead-instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where+instance {-# OVERLAPPING #-} ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp where pctyp = Proxy :: Proxy ctyp -instance OVERLAPPING_+instance {-# OVERLAPPING #-} ( AllMime (ctyp ': ctyp' ': ctyps) ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where allMimeRender p _ = zip (allMime p) (repeat "")@@ -334,14 +326,14 @@ -- * MimeRender Instances -- | `encode`-instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @urlEncodeAsForm@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@)-instance OVERLAPPABLE_+instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where mimeRender _ = urlEncodeAsForm
src/Servant/API/Internal/Test/ComprehensiveAPI.hs view
@@ -1,48 +1,6 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}---- | This is a module containing an API with all `Servant.API` combinators. It--- is used for testing only (in particular, checking that instances exist for--- the core servant classes for each combinator), and should not be imported.-module Servant.API.Internal.Test.ComprehensiveAPI where--import Data.Proxy-import Servant.API--type GET = Get '[JSON] NoContent--type ComprehensiveAPI =- ComprehensiveAPIWithoutRaw :<|>- Raw--comprehensiveAPI :: Proxy ComprehensiveAPI-comprehensiveAPI = Proxy--type ComprehensiveAPIWithoutRaw =- GET :<|>- Get '[JSON] Int :<|>- Capture' '[Description "example description"] "foo" Int :> GET :<|>- Header "foo" Int :> GET :<|>- Header' '[Required, Lenient] "bar" Int :> GET :<|>- HttpVersion :> GET :<|>- IsSecure :> GET :<|>- QueryParam "foo" Int :> GET :<|>- QueryParam' '[Required, Lenient] "bar" Int :> GET :<|>- QueryParams "foo" Int :> GET :<|>- QueryFlag "foo" :> GET :<|>- RemoteHost :> GET :<|>- ReqBody '[JSON] Int :> GET :<|>- ReqBody' '[Lenient] '[JSON] Int :> GET :<|>- Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>- "foo" :> GET :<|>- Vault :> GET :<|>- Verb 'POST 204 '[JSON] NoContent :<|>- Verb 'POST 204 '[JSON] Int :<|>- WithNamedContext "foo" '[] GET :<|>- CaptureAll "foo" Int :> GET :<|>- Summary "foo" :> GET :<|>- Description "foo" :> GET :<|>- EmptyAPI+module Servant.API.Internal.Test.ComprehensiveAPI+ {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-}+ ( module Servant.Test.ComprehensiveAPI )+ where -comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw-comprehensiveAPIWithoutRaw = Proxy+import Servant.Test.ComprehensiveAPI
src/Servant/API/ResponseHeaders.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -15,7 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int@@ -28,8 +26,11 @@ , AddHeader , addHeader , noHeader+ , HasResponseHeader+ , lookupResponseHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders)+ , GetHeaders' , HeaderValMap , HList(..) ) where@@ -80,10 +81,10 @@ -- the values are interspersed with commas before deserialization (see -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>) -instance OVERLAPPING_ BuildHeadersTo '[] where+instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )+instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo (Header h v ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)@@ -144,11 +145,11 @@ addOptionalHeader :: ResponseHeader h v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance OVERLAPPING_ ( KnownSymbol h, ToHttpApiData v )+instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads) -instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData v+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ (Headers '[Header h v] a) ) => AddHeader h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)@@ -184,7 +185,43 @@ noHeader :: AddHeader h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader +class HasResponseHeader h a headers where+ hlistLookupHeader :: HList headers -> ResponseHeader h a++instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where+ hlistLookupHeader (HCons ha _) = ha++instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where+ hlistLookupHeader (HCons _ hs) = hlistLookupHeader hs++-- | Look up a specific ResponseHeader,+-- without having to know what position it is in the HList.+--+-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String+-- >>> let example2 = addHeader True example1 :: Headers '[Header "1st" Bool, Header "someheader" Int] String+-- >>> lookupResponseHeader example2 :: ResponseHeader "someheader" Int+-- Header 5+--+-- >>> lookupResponseHeader example2 :: ResponseHeader "1st" Bool+-- Header True+--+-- Usage of this function relies on an explicit type annotation of the header to be looked up.+-- This can be done with type annotations on the result, or with an explicit type application.+-- In this example, the type of header value is determined by the type-inference,+-- we only specify the name of the header:+--+-- >>> :set -XTypeApplications+-- >>> case lookupResponseHeader @"1st" example2 of { Header b -> b ; _ -> False }+-- True+--+-- @since 0.15+--+lookupResponseHeader :: (HasResponseHeader h a headers)+ => Headers headers r -> ResponseHeader h a+lookupResponseHeader = hlistLookupHeader . getHeadersHList+ -- $setup+-- >>> :set -XFlexibleContexts -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text
src/Servant/API/Stream.hs view
@@ -1,23 +1,52 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Stream where+module Servant.API.Stream (+ Stream,+ StreamGet,+ StreamPost,+ StreamBody,+ StreamBody',+ -- * Source+ --+ -- | 'SourceIO' are equivalent to some *source* in streaming libraries.+ SourceIO,+ ToSourceIO (..),+ FromSourceIO (..),+ -- ** Auxiliary classes+ SourceToSourceIO (..),+ -- * Framing+ FramingRender (..),+ FramingUnrender (..),+ -- ** Strategies+ NoFraming,+ NewlineFraming,+ NetstringFraming,+ ) where -import Control.Arrow- (first)-import Data.ByteString.Lazy- (ByteString, empty)-import qualified Data.ByteString.Lazy.Char8 as LB++import Control.Applicative+ ((<|>))+import Control.Monad.IO.Class+ (MonadIO (..))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.List.NonEmpty+ (NonEmpty (..)) import Data.Monoid ((<>)) import Data.Proxy@@ -30,111 +59,178 @@ (Nat) import Network.HTTP.Types.Method (StdMethod (..))-import Text.Read- (readMaybe)+import Servant.Types.SourceT --- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods.+-- | A Stream endpoint for a given method emits a stream of encoded values at a+-- given @Content-Type@, delimited by a @framing@ strategy.+-- Type synonyms are provided for standard methods.+-- data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *) deriving (Typeable, Generic) type StreamGet = Stream 'GET 200 type StreamPost = Stream 'POST 200 --- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation).-newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}+-- | A stream request body.+type StreamBody = StreamBody' '[] --- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints.-class ToStreamGenerator a b | a -> b where- toStreamGenerator :: a -> StreamGenerator b+data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *)+ deriving (Typeable, Generic) -instance ToStreamGenerator (StreamGenerator a) a- where toStreamGenerator x = x+-------------------------------------------------------------------------------+-- Sources+------------------------------------------------------------------------------- --- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing.-newtype ResultStream a = ResultStream (forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b)+-- | Stream endpoints may be implemented as producing a @'SourceIO' chunk@.+--+-- Clients reading from streaming endpoints can be implemented as consuming a+-- @'SourceIO' chunk@.+--+type SourceIO = SourceT IO --- | BuildFromStream is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly on the client side for talking to streaming endpoints.-class BuildFromStream a b where- buildFromStream :: ResultStream a -> b+-- | 'ToSourceIO' is intended to be implemented for types such as Conduit, Pipe,+-- etc. By implementing this class, all such streaming abstractions can be used+-- directly as endpoints.+class ToSourceIO chunk a | a -> chunk where+ toSourceIO :: a -> SourceIO chunk -instance BuildFromStream a (ResultStream a)- where buildFromStream x = x+-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance.+class SourceToSourceIO m where+ sourceToSourceIO :: SourceT m a -> SourceT IO a --- | The FramingRender class provides the logic for emitting a framing strategy. The strategy emits a header, followed by boundary-delimited data, and finally a termination character. For many strategies, some of these will just be empty bytestrings.-class FramingRender strategy a where- header :: Proxy strategy -> Proxy a -> ByteString- boundary :: Proxy strategy -> Proxy a -> BoundaryStrategy- trailer :: Proxy strategy -> Proxy a -> ByteString+instance SourceToSourceIO IO where+ sourceToSourceIO = id --- | The bracketing strategy generates things to precede and follow the content, as with netstrings.--- The intersperse strategy inserts seperators between things, as with newline framing.--- Finally, the general strategy performs an arbitrary rewrite on the content, to allow escaping rules and such.-data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteString))- | BoundaryStrategyIntersperse ByteString- | BoundaryStrategyGeneral (ByteString -> ByteString)+-- | Relax to use auxiliary class, have m+instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where+ toSourceIO = sourceToSourceIO --- | A type of parser that can never fail, and has different parsing strategies (incremental, or EOF) depending if more input can be sent. The incremental parser should return `Nothing` if it would like to be sent a longer ByteString. If it returns a value, it also returns the remainder following that value.-data ByteStringParser a = ByteStringParser {- parseIncremental :: ByteString -> Maybe (a, ByteString),- parseEOF :: ByteString -> (a, ByteString)-}+instance ToSourceIO a (NonEmpty a) where+ toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs)) --- | The FramingUnrender class provides the logic for parsing a framing strategy. The outer @ByteStringParser@ strips the header from a stream of bytes, and yields a parser that can handle the remainder, stepwise. Each frame may be a ByteString, or a String indicating the error state for that frame. Such states are per-frame, so that protocols that can resume after errors are able to do so. Eventually this returns an empty ByteString to indicate termination.-class FramingUnrender strategy a where- unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString))+instance ToSourceIO a [a] where+ toSourceIO = source --- | A framing strategy that does not do any framing at all, it just passes the input data--- This will be used most of the time with binary data, such as files+-- | 'FromSourceIO' is intended to be implemented for types such as Conduit,+-- Pipe, etc. By implementing this class, all such streaming abstractions can+-- be used directly on the client side for talking to streaming endpoints.+class FromSourceIO chunk a | a -> chunk where+ fromSourceIO :: SourceIO chunk -> a++instance MonadIO m => FromSourceIO a (SourceT m a) where+ fromSourceIO = sourceFromSourceIO++sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a+sourceFromSourceIO src =+ SourceT $ \k ->+ k $ Effect $ liftIO $ unSourceT src (return . go)+ where+ go :: StepT IO a -> StepT m a+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (liftIO (fmap go ms))+ go (Yield x s) = Yield x (go s)++-- This fires e.g. in Client.lhs+-- {-# OPTIONS_GHC -ddump-simpl -ddump-rule-firings -ddump-to-file #-}+{-# NOINLINE [2] sourceFromSourceIO #-}+{-# RULES "sourceFromSourceIO @IO" sourceFromSourceIO = id :: SourceT IO a -> SourceT IO a #-}++-------------------------------------------------------------------------------+-- Framing+-------------------------------------------------------------------------------++-- | The 'FramingRender' class provides the logic for emitting a framing strategy.+-- The strategy transforms a @'SourceT' m a@ into @'SourceT' m 'LBS.ByteString'@,+-- therefore it can prepend, append and intercalate /framing/ structure+-- around chunks.+--+-- /Note:/ as the @'Monad' m@ is generic, this is pure transformation.+--+class FramingRender strategy where+ framingRender :: Monad m => Proxy strategy -> (a -> LBS.ByteString) -> SourceT m a -> SourceT m LBS.ByteString++-- | The 'FramingUnrender' class provides the logic for parsing a framing+-- strategy.+class FramingUnrender strategy where+ framingUnrender :: Monad m => Proxy strategy -> (LBS.ByteString -> Either String a) -> SourceT m BS.ByteString -> SourceT m a++-------------------------------------------------------------------------------+-- NoFraming+-------------------------------------------------------------------------------++-- | A framing strategy that does not do any framing at all, it just passes the+-- input data This will be used most of the time with binary data, such as+-- files data NoFraming -instance FramingRender NoFraming a where- header _ _ = empty- boundary _ _ = BoundaryStrategyGeneral id- trailer _ _ = empty+instance FramingRender NoFraming where+ framingRender _ = fmap -instance FramingUnrender NoFraming a where- unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)- where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right)+-- | As 'NoFraming' doesn't have frame separators, we take the chunks+-- as given and try to convert them one by one.+--+-- That works well when @a@ is a 'ByteString'.+instance FramingUnrender NoFraming where+ framingUnrender _ f = mapStepT go+ where+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (fmap go ms)+ go (Yield x s) = case f (LBS.fromStrict x) of+ Right y -> Yield y (go s)+ Left err -> Error err --- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.--- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).+-------------------------------------------------------------------------------+-- NewlineFraming+-------------------------------------------------------------------------------++-- | A simple framing strategy that has no header, and inserts a+-- newline character after each frame. This assumes that it is used with a+-- Content-Type that encodes without newlines (e.g. JSON). data NewlineFraming -instance FramingRender NewlineFraming a where- header _ _ = empty- boundary _ _ = BoundaryStrategyIntersperse "\n"- trailer _ _ = empty+instance FramingRender NewlineFraming where+ framingRender _ f = fmap (\x -> f x <> "\n") -instance FramingUnrender NewlineFraming a where- unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)- where go = ByteStringParser- (\x -> case LB.break (== '\n') x of- (h,r) -> if not (LB.null r) then Just (Right h, LB.drop 1 r) else Nothing- )- (\x -> case LB.break (== '\n') x of- (h,r) -> (Right h, LB.drop 1 r)- )--- | The netstring framing strategy as defined by djb: <http://cr.yp.to/proto/netstrings.txt>-data NetstringFraming+instance FramingUnrender NewlineFraming where+ framingUnrender _ f = transformWithAtto $ do+ bs <- A.takeWhile (/= 10)+ () <$ A.word8 10 <|> A.endOfInput+ either fail pure (f (LBS.fromStrict bs)) -instance FramingRender NetstringFraming a where- header _ _ = empty- boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")- trailer _ _ = empty+-------------------------------------------------------------------------------+-- NetstringFraming+------------------------------------------------------------------------------- +-- | The netstring framing strategy as defined by djb:+-- <http://cr.yp.to/proto/netstrings.txt>+--+-- Any string of 8-bit bytes may be encoded as @[len]":"[string]","@. Here+-- @[string]@ is the string and @[len]@ is a nonempty sequence of ASCII digits+-- giving the length of @[string]@ in decimal. The ASCII digits are @<30>@ for+-- 0, @<31>@ for 1, and so on up through @<39>@ for 9. Extra zeros at the front+-- of @[len]@ are prohibited: @[len]@ begins with @<30>@ exactly when+-- @[string]@ is empty.+--+-- For example, the string @"hello world!"@ is encoded as+-- @<31 32 3a 68 65 6c 6c 6f 20 77 6f 72 6c 64 21 2c>@,+-- i.e., @"12:hello world!,"@.+-- The empty string is encoded as @"0:,"@.+--+data NetstringFraming -instance FramingUnrender NetstringFraming a where- unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)- where go = ByteStringParser- (\b -> let (i,r) = LB.break (==':') b- in case readMaybe (LB.unpack i) of- Just len -> if LB.length r > len- then Just . first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r- else Nothing- Nothing -> Just (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))- (\b -> let (i,r) = LB.break (==':') b- in case readMaybe (LB.unpack i) of- Just len -> if LB.length r > len- then first Right . fmap (LB.drop 1) $ LB.splitAt len . LB.drop 1 $ r- else (Right $ LB.take len r, LB.empty)- Nothing -> (Left ("Bad netstring frame, couldn't parse value as integer value: " ++ LB.unpack i), LB.drop 1 . LB.dropWhile (/= ',') $ r))+instance FramingRender NetstringFraming where+ framingRender _ f = fmap $ \x ->+ let bs = f x+ in LBS8.pack (show (LBS8.length bs)) <> ":" <> bs <> ","++instance FramingUnrender NetstringFraming where+ framingUnrender _ f = transformWithAtto $ do+ len <- A8.decimal+ _ <- A8.char ':'+ bs <- A.take len+ _ <- A8.char ','+ either fail pure (f (LBS.fromStrict bs))
src/Servant/API/TypeLevel.hs view
@@ -41,9 +41,6 @@ -- ** Logic Or, And,- -- * Custom type errors- -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class,- -- which cannot be instantiated. ) where @@ -63,10 +60,8 @@ (type (:>)) import Servant.API.Verbs (Verb)-#if MIN_VERSION_base(4,9,0) import GHC.TypeLits (ErrorMessage (..), TypeError)-#endif @@ -222,14 +217,10 @@ type family ElemGo e es orig :: Constraint where ElemGo x (x ': xs) orig = () ElemGo y (x ': xs) orig = ElemGo y xs orig-#if MIN_VERSION_base(4,9,0) -- Note [Custom Errors] ElemGo x '[] orig = TypeError ('ShowType x ':<>: 'Text " expected in list " ':<>: 'ShowType orig)-#else- ElemGo x '[] orig = ElemNotFoundIn x orig-#endif -- ** Logic @@ -243,12 +234,6 @@ -- | If both a or b produce an empty constraint, produce an empty constraint. type family And (a :: Constraint) (b :: Constraint) :: Constraint where And () () = ()---- * Custom type errors--#if !MIN_VERSION_base(4,9,0)-class ElemNotFoundIn val list-#endif {- Note [Custom Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
src/Servant/API/Verbs.hs view
@@ -56,14 +56,17 @@ -- Indicates that a new resource has been created. The URI corresponding to the -- resource should be given in the @Location@ header field. --+-- If the operation is idempotent, use 'PutCreated'. If not, use 'PostCreated'+-- -- If the resource cannot be created immediately, use 'PostAccepted'. -- -- Consider using 'Servant.Links.safeLink' for the @Location@ header -- field. -- | 'POST' with 201 status code.--- type PostCreated = Verb 'POST 201+-- | 'PUT' with 201 status code.+type PutCreated = Verb 'PUT 201 -- ** 202 Accepted
src/Servant/Links.hs view
@@ -170,7 +170,7 @@ import Servant.API.ReqBody (ReqBody') import Servant.API.Stream- (Stream)+ (Stream, StreamBody') import Servant.API.Sub (type (:>)) import Servant.API.TypeLevel@@ -480,6 +480,10 @@ -- Misc instances instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r+ toLink toA _ = toLink toA (Proxy :: Proxy sub)++instance HasLink sub => HasLink (StreamBody' mods framing ct a :> sub) where+ type MkLink (StreamBody' mods framing ct a :> sub) r = MkLink sub r toLink toA _ = toLink toA (Proxy :: Proxy sub) instance (ToHttpApiData v, HasLink sub)
+ src/Servant/Test/ComprehensiveAPI.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | This is a module containing an API with all `Servant.API` combinators. It+-- is used for testing only (in particular, checking that instances exist for+-- the core servant classes for each combinator).+module Servant.Test.ComprehensiveAPI where++import Data.Proxy+ (Proxy (..))+import Servant.API+import Servant.Types.SourceT+ (SourceT)++type GET = Get '[JSON] NoContent++type ComprehensiveAPI =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> StreamingEndpoint :<|> RawEndpoint)++type RawEndpoint =+ "raw" :> Raw++type StreamingEndpoint =+ "streaming" :> StreamBody' '[Description "netstring"] NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int)++type EmptyEndpoint =+ "empty-api" :> EmptyAPI++comprehensiveAPI :: Proxy ComprehensiveAPI+comprehensiveAPI = Proxy++type ComprehensiveAPIWithoutRaw =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> StreamingEndpoint)++comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw+comprehensiveAPIWithoutRaw = Proxy++type ComprehensiveAPIWithoutStreaming =+ ComprehensiveAPIWithoutStreamingOrRaw'+ (EmptyEndpoint :<|> RawEndpoint)++comprehensiveAPIWithoutStreaming :: Proxy ComprehensiveAPIWithoutStreaming+comprehensiveAPIWithoutStreaming = Proxy++-- | @:: API -> API@, so we have linear structure of the API.+type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =+ GET+ :<|> "get-int" :> Get '[JSON] Int+ :<|> "capture" :> Capture' '[Description "example description"] "foo" Int :> GET+ :<|> "header" :> Header "foo" Int :> GET+ :<|> "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET+ :<|> "http-version" :> HttpVersion :> GET+ :<|> "is-secure" :> IsSecure :> GET+ :<|> "param" :> QueryParam "foo" Int :> GET+ :<|> "param-lenient" :> QueryParam' '[Required, Lenient] "bar" Int :> GET+ :<|> "params" :> QueryParams "foo" Int :> GET+ :<|> "flag" :> QueryFlag "foo" :> GET+ :<|> "remote-host" :> RemoteHost :> GET+ :<|> "req-body" :> ReqBody '[JSON] Int :> GET+ :<|> "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET+ :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent)+ :<|> "foo" :> GET+ :<|> "vault" :> Vault :> GET+ :<|> "post-no-content" :> Verb 'POST 204 '[JSON] NoContent+ :<|> "post-int" :> Verb 'POST 204 '[JSON] Int+ :<|> "named-context" :> WithNamedContext "foo" '[] GET+ :<|> "capture-all" :> CaptureAll "foo" Int :> GET+ :<|> "summary" :> Summary "foo" :> GET+ :<|> "description" :> Description "foo" :> GET+ :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET)+ :<|> endpoint++type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint++comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw+comprehensiveAPIWithoutStreamingOrRaw = Proxy
+ src/Servant/Types/SourceT.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.Types.SourceT where++import Control.Monad.Except+ (ExceptT (..), runExceptT, throwError)+import Control.Monad.Morph+ (MFunctor (..))+import Control.Monad.Trans.Class+ (MonadTrans (..))+import qualified Data.Attoparsec.ByteString as A+import qualified Data.ByteString as BS+import Data.Functor.Classes+ (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith)+import Data.Functor.Identity+ (Identity (..))+import Prelude ()+import Prelude.Compat hiding+ (readFile)+import System.IO+ (Handle, IOMode (..), withFile)+import qualified Test.QuickCheck as QC++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Control.Monad.Except (runExcept)+-- >>> import Data.Foldable (toList)+-- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8++-- | This is CPSised ListT.+--+-- @since 0.15+--+newtype SourceT m a = SourceT+ { unSourceT :: forall b. (StepT m a -> m b) -> m b+ }++mapStepT :: (StepT m a -> StepT m b) -> SourceT m a -> SourceT m b+mapStepT f (SourceT m) = SourceT $ \k -> m (k . f)+{-# INLINE mapStepT #-}++-- | @ListT@ with additional constructors.+--+-- @since 0.15+--+data StepT m a+ = Stop+ | Error String -- we can this argument configurable.+ | Skip (StepT m a) -- Note: not sure about this constructor+ | Yield a (StepT m a)+ | Effect (m (StepT m a))+ deriving Functor++-- | Create 'SourceT' from 'Step'.+--+-- /Note:/ often enough you want to use 'SourceT' directly.+fromStepT :: StepT m a -> SourceT m a+fromStepT s = SourceT ($ s)++-------------------------------------------------------------------------------+-- SourceT instances+-------------------------------------------------------------------------------++instance Functor m => Functor (SourceT m) where+ fmap f = mapStepT (fmap f)++-- | >>> toList (source [1..10])+-- [1,2,3,4,5,6,7,8,9,10]+--+instance Identity ~ m => Foldable (SourceT m) where+ foldr f z (SourceT m) = foldr f z (runIdentity (m Identity))++instance (Applicative m, Show1 m) => Show1 (SourceT m) where+ liftShowsPrec sp sl d (SourceT m) = showsUnaryWith+ (liftShowsPrec sp sl)+ "fromStepT" d (Effect (m pure'))+ where+ pure' (Effect s) = s+ pure' s = pure s++instance (Applicative m, Show1 m, Show a) => Show (SourceT m a) where+ showsPrec = showsPrec1++-- | >>> hoist (Just . runIdentity) (source [1..3]) :: SourceT Maybe Int+-- fromStepT (Effect (Just (Yield 1 (Yield 2 (Yield 3 Stop)))))+instance MFunctor SourceT where+ hoist f (SourceT m) = SourceT $ \k -> k $+ Effect $ f $ fmap (hoist f) $ m return++-- | Doesn't generate 'Error' constructors. 'SourceT' doesn't shrink.+instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (SourceT m a) where+ arbitrary = fromStepT <$> QC.arbitrary++-- An example of above instance. Not doctested because it's volatile.+--+-- >>> import Test.QuickCheck as QC+-- >>> import Test.QuickCheck.Gen as QC+-- >>> import Test.QuickCheck.Random as QC+-- >>> let generate (QC.MkGen g) = g (QC.mkQCGen 44) 10+--+-- >>> generate (arbitrary :: QC.Gen (SourceT Identity Int))+-- fromStepT (Effect (Identity (Yield (-10) (Yield 3 (Skip (Yield 1 Stop))))))++-------------------------------------------------------------------------------+-- StepT instances+-------------------------------------------------------------------------------++instance Identity ~ m => Foldable (StepT m) where+ foldr f z = go where+ go Stop = z+ go (Error _) = z+ go (Skip s) = go s+ go (Yield a s) = f a (go s)+ go (Effect (Identity s)) = go s++instance (Applicative m, Show1 m) => Show1 (StepT m) where+ liftShowsPrec sp sl = go where+ go _ Stop = showString "Stop"+ go d (Skip s) = showsUnaryWith+ go+ "Skip" d s+ go d (Error err) = showsUnaryWith+ showsPrec+ "Error" d err+ go d (Effect ms) = showsUnaryWith+ (liftShowsPrec go goList)+ "Effect" d ms+ go d (Yield x s) = showsBinaryWith+ sp go+ "Yield" d x s++ goList = liftShowList sp sl++instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where+ showsPrec = showsPrec1++-- | >>> lift [1,2,3] :: StepT [] Int+-- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop]+--+instance MonadTrans StepT where+ lift = Effect . fmap (`Yield` Stop)++instance MFunctor StepT where+ hoist f = go where+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Yield x s) = Yield x (go s)+ go (Effect ms) = Effect (f (fmap go ms))++-- | Doesn't generate 'Error' constructors.+instance (QC.Arbitrary a, Monad m) => QC.Arbitrary (StepT m a) where+ arbitrary = QC.sized arb where+ arb n | n <= 0 = pure Stop+ | otherwise = QC.frequency+ [ (1, pure Stop)+ , (1, Skip <$> arb')+ , (1, Effect . return <$> arb')+ , (8, Yield <$> QC.arbitrary <*> arb')+ ]+ where+ arb' = arb (n - 1)++ shrink Stop = []+ shrink (Error _) = [Stop]+ shrink (Skip s) = [s]+ shrink (Effect _) = []+ shrink (Yield x s) =+ [ Yield x' s | x' <- QC.shrink x ] +++ [ Yield x s' | s' <- QC.shrink s ]++-------------------------------------------------------------------------------+-- Operations+-------------------------------------------------------------------------------++-- | Create pure 'SourceT'.+--+-- >>> source "foo" :: SourceT Identity Char+-- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop)))))+--+source :: [a] -> SourceT m a+source = fromStepT . foldr Yield Stop++-- | Get the answers.+--+-- >>> runSourceT (source "foo" :: SourceT Identity Char)+-- ExceptT (Identity (Right "foo"))+--+-- >>> runSourceT (source "foo" :: SourceT [] Char)+-- ExceptT [Right "foo"]+--+runSourceT :: Monad m => SourceT m a -> ExceptT String m [a]+runSourceT (SourceT m) = ExceptT (m (runExceptT . runStepT))++runStepT :: Monad m => StepT m a -> ExceptT String m [a]+runStepT Stop = return []+runStepT (Error err) = throwError err+runStepT (Skip s) = runStepT s+runStepT (Yield x s) = fmap (x :) (runStepT s)+runStepT (Effect ms) = lift ms >>= runStepT++{-+-- | >>> uncons (foldr Yield Stop "foo" :: StepT Identity Char)+-- Identity (Just ('f',Yield 'o' (Yield 'o' Stop)))+--+uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))+uncons Stop = return Nothing+uncons (Skip s) = uncons s+uncons (Yield x s) = return (Just (x, s))+uncons (Effect ms) = ms >>= uncons+uncons (Error _) =+-}++-- | Filter values.+--+-- >>> toList $ mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..10]) :: [Int]+-- [1,3,5,7,9]+--+-- >>> mapMaybe (\x -> if odd x then Just x else Nothing) (source [0..2]) :: SourceT Identity Int+-- fromStepT (Effect (Identity (Skip (Yield 1 (Skip Stop)))))+--+-- Illustrates why we need 'Skip'.+mapMaybe :: Functor m => (a -> Maybe b) -> SourceT m a -> SourceT m b+mapMaybe p (SourceT m) = SourceT $ \k -> m (k . mapMaybeStep p)++mapMaybeStep :: Functor m => (a -> Maybe b) -> StepT m a -> StepT m b+mapMaybeStep p = go where+ go Stop = Stop+ go (Error err) = Error err+ go (Skip s) = Skip (go s)+ go (Effect ms) = Effect (fmap go ms)+ go (Yield x s) = case p x of+ Nothing -> Skip (go s)+ Just y -> Yield y (go s)++-- | Run action for each value in the 'SourceT'.+--+-- >>> foreach fail print (source "abc")+-- 'a'+-- 'b'+-- 'c'+--+foreach+ :: Monad m+ => (String -> m ()) -- ^ error handler+ -> (a -> m ())+ -> SourceT m a+ -> m ()+foreach f g src = unSourceT src (foreachStep f g)++-- | See 'foreach'.+foreachStep+ :: Monad m+ => (String -> m ()) -- ^ error handler+ -> (a -> m ())+ -> StepT m a+ -> m ()+foreachStep f g = go where+ go Stop = return ()+ go (Skip s) = go s+ go (Yield x s) = g x >> go s+ go (Error err) = f err+ go (Effect ms) = ms >>= go++-------------------------------------------------------------------------------+-- Monadic+-------------------------------------------------------------------------------++fromAction :: Functor m => (a -> Bool) -> m a -> SourceT m a+fromAction stop action = SourceT ($ fromActionStep stop action)+{-# INLINE fromAction #-}++fromActionStep :: Functor m => (a -> Bool) -> m a -> StepT m a+fromActionStep stop action = loop where+ loop = Effect $ fmap step action+ step x+ | stop x = Stop+ | otherwise = Yield x loop+{-# INLINE fromActionStep #-}++-------------------------------------------------------------------------------+-- File+-------------------------------------------------------------------------------++-- | Read file.+--+-- >>> foreach fail BS.putStr (readFile "servant.cabal")+-- cabal-version: >=1.10+-- name: servant+-- ...+--+readFile :: FilePath -> SourceT IO BS.ByteString+readFile fp =+ SourceT $ \k ->+ withFile fp ReadMode $ \hdl ->+ k (readHandle hdl)+ where+ readHandle :: Handle -> StepT IO BS.ByteString+ readHandle hdl = fromActionStep BS.null (BS.hGet hdl 4096)++-------------------------------------------------------------------------------+-- Attoparsec+-------------------------------------------------------------------------------++-- | Transform using @attoparsec@ parser.+--+-- Note: @parser@ should not accept empty input!+--+-- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1 2 3"])+-- Right ["1","2","3"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"])+-- Right ["123"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"])+-- Right ["12","34"]+--+-- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["foobar"])+-- Left "Failed reading: takeWhile1"+--+transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a+transformWithAtto parser = mapStepT (transformStepWithAtto parser)++transformStepWithAtto+ :: forall a m. Monad m+ => A.Parser a -> StepT m BS.ByteString -> StepT m a+transformStepWithAtto parser = go (A.parse parser) where+ p0 = A.parse parser++ go :: (BS.ByteString -> A.Result a)+ -> StepT m BS.ByteString -> StepT m a+ go _ (Error err) = Error err+ go p (Skip s) = Skip (go p s)+ go p (Effect ms) = Effect (fmap (go p) ms)+ go p Stop = case p mempty of+ A.Fail _ _ err -> Error err+ A.Done _ a -> Yield a Stop+ A.Partial _ -> Stop+ go p (Yield bs0 s) = loop p bs0 where+ loop p' bs+ | BS.null bs = Skip (go p' s)+ | otherwise = case p' bs of+ A.Fail _ _ err -> Error err+ A.Done bs' a -> Yield a (loop p0 bs')+ A.Partial p'' -> Skip (go p'' s)
− src/Servant/Utils/Enter.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (- module Servant.Utils.Enter,- -- * natural-transformation re-exports- (:~>)(..),- ) where--import Control.Monad.Identity-import Control.Monad.Morph-import Control.Monad.Reader-import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState-import qualified Control.Monad.Writer.Lazy as LWriter-import qualified Control.Monad.Writer.Strict as SWriter-import Control.Natural-import Data.Tagged- (Tagged, retag)-import Prelude ()-import Prelude.Compat-import Servant.API---- | Helper type family to state the 'Enter' symmetry.-type family Entered m n api where- Entered m n (a -> api) = a -> Entered m n api- Entered m n (m a) = n a- Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2- Entered m n (Tagged m a) = Tagged n a--class- ( Entered m n typ ~ ret- , Entered n m ret ~ typ- ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m- where- -- | Map the leafs of an API type.- enter :: (m :~> n) -> typ -> ret---- ** Servant combinators--instance- ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2- , m1 ~ m2, n1 ~ n2- , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)- , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)- ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)- where- enter e (a :<|> b) = enter e a :<|> enter e b--instance- ( Enter typ m n ret- , Entered m n (a -> typ) ~ (a -> ret)- , Entered n m (a -> ret) ~ (a -> typ)- ) => Enter (a -> typ) m n (a -> ret)- where- enter arg f a = enter arg (f a)---- ** Leaf instances--instance- ( Entered m n (Tagged m a) ~ Tagged n a- , Entered n m (Tagged n a) ~ Tagged m a- ) => Enter (Tagged m a) m n (Tagged n a)- where- enter _ = retag--instance- ( Entered m n (m a) ~ n a- , Entered n m (n a) ~ m a- ) => Enter (m a) m n (n a)- where- enter (NT f) = f---- | Like `lift`.-liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m-liftNat = NT Control.Monad.Morph.lift--runReaderTNat :: r -> (ReaderT r m :~> m)-runReaderTNat a = NT (`runReaderT` a)--evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)-evalStateTLNat a = NT (`LState.evalStateT` a)--evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)-evalStateTSNat a = NT (`SState.evalStateT` a)---- | Log the contents of `SWriter.WriterT` with the function provided as the--- first argument, and return the value of the @WriterT@ computation-logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)-logWriterTSNat logger = NT $ \x -> do- (a, w) <- SWriter.runWriterT x- liftIO $ logger w- return a---- | Like `logWriterTSNat`, but for lazy @WriterT@.-logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)-logWriterTLNat logger = NT $ \x -> do- (a, w) <- LWriter.runWriterT x- liftIO $ logger w- return a---- | Like @mmorph@'s `hoist`.-hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)-hoistNat (NT n) = NT $ hoist n---- | Like @mmorph@'s `embed`.-embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)-embedNat (NT n) = NT $ embed n---- | Like @mmorph@'s `squash`.-squashNat :: (Monad m, MMonad t) => t (t m) :~> t m-squashNat = NT squash---- | Like @mmorph@'s `generalize`.-generalizeNat :: Applicative m => Identity :~> m-generalizeNat = NT (pure . runIdentity)
test/Servant/API/ContentTypesSpec.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -11,26 +10,34 @@ import Prelude () import Prelude.Compat -import Data.Aeson.Compat-import Data.ByteString.Char8 (ByteString, append, pack)-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSL8+import Data.Aeson+ (FromJSON, ToJSON (..), Value, decode, encode, object, (.=))+import Data.ByteString.Char8+ (ByteString, append, pack)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Either-import Data.Function (on)-import Data.List (maximumBy)-import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromJust, isJust, isNothing)+import Data.Function+ (on)+import Data.List+ (maximumBy)+import qualified Data.List.NonEmpty as NE+import Data.Maybe+ (fromJust, isJust, isNothing) import Data.Proxy-import Data.String (IsString (..))-import Data.String.Conversions (cs)-import qualified Data.Text as TextS-import qualified Data.Text.Encoding as TextSE-import qualified Data.Text.Lazy as TextL+import Data.String+ (IsString (..))+import Data.String.Conversions+ (cs)+import qualified Data.Text as TextS+import qualified Data.Text.Encoding as TextSE+import qualified Data.Text.Lazy as TextL import GHC.Generics import Test.Hspec import Test.QuickCheck-import Text.Read (readMaybe)-import "quickcheck-instances" Test.QuickCheck.Instances ()+import "quickcheck-instances" Test.QuickCheck.Instances ()+import Text.Read+ (readMaybe) import Servant.API.ContentTypes @@ -188,7 +195,6 @@ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg" "foobar" `shouldBe` (Nothing :: Maybe (Either String Int)) -#if MIN_VERSION_aeson(0,9,0) -- aeson >= 0.9 decodes top-level strings describe "eitherDecodeLenient" $ do @@ -197,7 +203,6 @@ -- The Left messages differ, so convert to Maybe property $ \x -> toMaybe (eitherDecodeLenient x) `shouldBe` (decode x :: Maybe String)-#endif data SomeData = SomeData { record1 :: String, record2 :: Int }
test/Servant/API/ResponseHeadersSpec.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where -import Test.Hspec+import Test.Hspec -import Servant.API.Header-import Servant.API.ResponseHeaders+import Servant.API.Header+import Servant.API.ResponseHeaders spec :: Spec spec = describe "Servant.API.ResponseHeaders" $ do
+ test/Servant/API/StreamSpec.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module Servant.API.StreamSpec where++import Control.Monad.Except+ (runExcept)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Functor.Identity+ (Identity (..))+import Data.Proxy+ (Proxy (..))+import Data.String+ (fromString)+import Servant.API.Stream+import Servant.Types.SourceT+import Test.Hspec+import Test.QuickCheck+ (Property, property, (===))+import Test.QuickCheck.Instances ()++spec :: Spec+spec = describe "Servant.API.Stream" $ do+ describe "NoFraming" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NoFraming) (Right . LBS.toStrict)+ framingRender' = framingRender (Proxy :: Proxy NoFraming) LBS.fromStrict++ it "framingUnrender" $+ property $ \bss ->+ runUnrenderFrames framingUnrender' bss === map Right (bss :: [BS.ByteString])++ it "roundtrip" $+ property $ roundtrip framingRender' framingUnrender'++ describe "NewlineFraming" $ do+ let tp = framingUnrender (Proxy :: Proxy NewlineFraming) (Right . LBS.toStrict)+ let re = framingRender (Proxy :: Proxy NewlineFraming) id++ it "framingRender examples" $ do+ runRenderFrames re [] `shouldBe` Right ""+ runRenderFrames re ["foo", "bar", "baz"] `shouldBe` Right "foo\nbar\nbaz\n"++ it "framingUnrender examples" $ do+ let expected n = map Right [fromString ("foo" ++ show (n :: Int)), "bar", "baz"]++ runUnrenderFrames tp ["foo1\nbar\nbaz"] `shouldBe` expected 1+ runUnrenderFrames tp ["foo2\n", "bar\n", "baz"] `shouldBe` expected 2+ runUnrenderFrames tp ["foo3\nb", "ar\nbaz"] `shouldBe` expected 3++ it "roundtrip" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NewlineFraming) Aeson.eitherDecode+ let framingRender' = framingRender (Proxy :: Proxy NewlineFraming) (Aeson.encode :: Int -> LBS.ByteString)++ property $ roundtrip framingRender' framingUnrender'++ -- it "fails if input doesn't contain newlines often" $+ -- runUnrenderFrames tp ["foo", "bar"] `shouldSatisfy` any isLeft++ describe "NetstringFraming" $ do+ let tp = framingUnrender (Proxy :: Proxy NetstringFraming) (Right . LBS.toStrict)+ let re = framingRender (Proxy :: Proxy NetstringFraming) id++ it "framingRender examples" $ do+ runRenderFrames re [] `shouldBe` Right ""+ runRenderFrames re ["foo", "bar", "baz"] `shouldBe` Right "3:foo,3:bar,3:baz,"++ it "framingUnrender examples" $ do+ let expected n = map Right [fromString ("foo" ++ show (n :: Int)), "bar", "baz"]++ runUnrenderFrames tp ["4:foo1,3:bar,3:baz,"] `shouldBe` expected 1+ runUnrenderFrames tp ["4:foo2,", "3:bar,", "3:baz,"] `shouldBe` expected 2+ runUnrenderFrames tp ["4:foo3,3:b", "ar,3:baz,"] `shouldBe` expected 3++ it "roundtrip" $ do+ let framingUnrender' = framingUnrender (Proxy :: Proxy NetstringFraming) Aeson.eitherDecode+ let framingRender' = framingRender (Proxy :: Proxy NetstringFraming) (Aeson.encode :: Int -> LBS.ByteString)++ property $ roundtrip framingRender' framingUnrender'++roundtrip+ :: (Eq a, Show a)+ => (SourceT Identity a -> SourceT Identity LBS.ByteString)+ -> (SourceT Identity BS.ByteString -> SourceT Identity a)+ -> [a]+ -> Property+roundtrip render unrender xs =+ map Right xs === runUnrenderFrames (unrender . fmap LBS.toStrict . render) xs++runRenderFrames :: (SourceT Identity a -> SourceT Identity LBS.ByteString) -> [a] -> Either String LBS.ByteString+runRenderFrames f = fmap mconcat . runExcept . runSourceT . f . source++runUnrenderFrames :: (SourceT Identity b -> SourceT Identity a) -> [b] -> [Either String a]+runUnrenderFrames f = go . Effect . flip unSourceT return . f . source where+ go :: StepT Identity a -> [Either String a]+ go Stop = []+ go (Error err) = [Left err]+ go (Skip s) = go s+ go (Yield x s) = Right x : go s+ go (Effect ms) = go (runIdentity ms)
test/Servant/LinksSpec.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ < 709-{-# OPTIONS_GHC -fcontext-stack=41 #-}-#endif+{-# LANGUAGE TypeOperators #-} module Servant.LinksSpec where -import Data.Proxy (Proxy (..))-import Test.Hspec (Expectation, Spec, describe, it,- shouldBe)-import Data.String (fromString)+import Data.Proxy+ (Proxy (..))+import Data.String+ (fromString)+import Test.Hspec+ (Expectation, Spec, describe, it, shouldBe) import Servant.API+import Servant.Test.ComprehensiveAPI+ (comprehensiveAPIWithoutRaw) import Servant.Links-import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) type TestApi = -- Capture and query params@@ -90,7 +89,7 @@ allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius" it "can generate all links for ComprehensiveAPIWithoutRaw" $ do- let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw+ let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` "" -- |
− test/Servant/Utils/EnterSpec.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-module Servant.Utils.EnterSpec where--import Test.Hspec (Spec)--import Servant.API-import Servant.Utils.Enter------------------------------------------------------------------------------------ https://github.com/haskell-servant/servant/issues/734------------------------------------------------------------------------------------ This didn't fail if executed in GHCi; cannot have as a doctest.--data App a--f :: App :~> App-f = NT id--server :: App Int :<|> (String -> App Bool)-server = undefined--server' :: App Int :<|> (String -> App Bool)-server' = enter f server------------------------------------------------------------------------------------ Spec----------------------------------------------------------------------------------spec :: Spec-spec = return ()
test/doctests.hs view
@@ -13,9 +13,11 @@ ----------------------------------------------------------------------------- module Main where -import Build_doctests (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-import Test.DocTest+import Build_doctests+ (flags, module_sources, pkgs)+import Data.Foldable+ (traverse_)+import Test.DocTest main :: IO () main = do