summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorphadej <>2018-11-13 16:10:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-11-13 16:10:00 (GMT)
commitb34e10e7e43e2d977b50050b2e2254cc73261b26 (patch)
tree5cacf966114c7819a9c55913d36dafbdf8990c9d
parentc146bcacca0e307118a047e19307fadb9b636761 (diff)
version 0.150.15
-rwxr-xr-x[-rw-r--r--]CHANGELOG.md161
-rw-r--r--LICENSE2
-rw-r--r--Setup.hs (renamed from Setup.lhs)8
-rw-r--r--include/overlapping-compat.h8
-rw-r--r--servant.cabal105
-rw-r--r--src/Servant/API.hs17
-rw-r--r--src/Servant/API/Alternative.hs22
-rw-r--r--src/Servant/API/ContentTypes.hs24
-rw-r--r--src/Servant/API/Internal/Test/ComprehensiveAPI.hs52
-rw-r--r--src/Servant/API/ResponseHeaders.hs49
-rw-r--r--src/Servant/API/Stream.hs320
-rw-r--r--src/Servant/API/TypeLevel.hs15
-rw-r--r--src/Servant/API/Verbs.hs5
-rw-r--r--src/Servant/Links.hs6
-rw-r--r--src/Servant/Test/ComprehensiveAPI.hs78
-rw-r--r--src/Servant/Types/SourceT.hs349
-rw-r--r--src/Servant/Utils/Enter.hs122
-rw-r--r--test/Servant/API/ContentTypesSpec.hs41
-rw-r--r--test/Servant/API/ResponseHeadersSpec.hs8
-rw-r--r--test/Servant/API/StreamSpec.hs99
-rw-r--r--test/Servant/LinksSpec.hs27
-rw-r--r--test/Servant/Utils/EnterSpec.hs33
-rw-r--r--test/doctests.hs8
23 files changed, 1098 insertions, 461 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index e7da769..0932031 100644..100755
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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`.
diff --git a/LICENSE b/LICENSE
index 9717a9c..c6a28c2 100644
--- 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/Setup.lhs b/Setup.hs
index 059c382..8ec54a0 100644
--- a/Setup.lhs
+++ b/Setup.hs
@@ -1,4 +1,3 @@
-\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where
@@ -16,6 +15,11 @@ 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.
@@ -27,5 +31,3 @@ main :: IO ()
main = defaultMain
#endif
-
-\end{code}
diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h
deleted file mode 100644
index eef9d4e..0000000
--- 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.cabal b/servant.cabal
index 17ae209..2a8fb84 100644
--- a/servant.cabal
+++ b/servant.cabal
@@ -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 @@ library
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 @@ library
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 @@ library
, 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 @@ test-suite spec
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 @@ test-suite spec
, 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 @@ test-suite doctests
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
diff --git a/src/Servant/API.hs b/src/Servant/API.hs
index 1a85e1a..b9c1c78 100644
--- a/src/Servant/API.hs
+++ b/src/Servant/API.hs
@@ -110,15 +110,14 @@ import Servant.API.ReqBody
(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 @@ import Servant.API.Verbs
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)
diff --git a/src/Servant/API/Alternative.hs b/src/Servant/API/Alternative.hs
index 5f8e393..60152ac 100644
--- a/src/Servant/API/Alternative.hs
+++ b/src/Servant/API/Alternative.hs
@@ -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
@@ -33,6 +42,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
-- >>> import Data.Aeson
diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs
index 797d058..5df6063 100644
--- a/src/Servant/API/ContentTypes.hs
+++ b/src/Servant/API/ContentTypes.hs
@@ -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 qualified Data.Text.Lazy.Encoding as TextL
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 @@ class (AllMime list) => AllCTRender (list :: [*]) a where
-- 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 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
-> 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 @@ instance OVERLAPPABLE_
-- 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 @@ instance ( MimeUnrender ctyp a
-- * 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
diff --git a/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
index ed1b520..ee2609c 100644
--- a/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
+++ b/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
@@ -1,48 +1,6 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
+module Servant.API.Internal.Test.ComprehensiveAPI
+ {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-}
+ ( module Servant.Test.ComprehensiveAPI )
+ where
--- | 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
-
-comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw
-comprehensiveAPIWithoutRaw = Proxy
+import Servant.Test.ComprehensiveAPI
diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs
index a0036c9..e5ff1ed 100644
--- a/src/Servant/API/ResponseHeaders.hs
+++ b/src/Servant/API/ResponseHeaders.hs
@@ -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 @@ module Servant.API.ResponseHeaders
, AddHeader
, addHeader
, noHeader
+ , HasResponseHeader
+ , lookupResponseHeader
, BuildHeadersTo(buildHeadersTo)
, GetHeaders(getHeaders)
+ , GetHeaders'
, HeaderValMap
, HList(..)
) where
@@ -80,10 +81,10 @@ class BuildHeadersTo hs where
-- 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 @@ class AddHeader h v orig new
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 @@ addHeader = addOptionalHeader . Header
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
diff --git a/src/Servant/API/Stream.hs b/src/Servant/API/Stream.hs
index 6a44eae..64164f5 100644
--- a/src/Servant/API/Stream.hs
+++ b/src/Servant/API/Stream.hs
@@ -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 #-}
-
-module Servant.API.Stream where
-
-import Control.Arrow
- (first)
-import Data.ByteString.Lazy
- (ByteString, empty)
-import qualified Data.ByteString.Lazy.Char8 as LB
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+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.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 @@ import GHC.TypeLits
(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
-
-instance ToStreamGenerator (StreamGenerator a) a
- where toStreamGenerator x = x
-
--- | 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)
-
--- | 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
-
-instance BuildFromStream a (ResultStream a)
- where buildFromStream x = x
-
--- | 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
-
--- | 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)
-
--- | 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)
-}
-
--- | 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))
+data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *)
+ deriving (Typeable, Generic)
--- | 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
+-------------------------------------------------------------------------------
+-- Sources
+-------------------------------------------------------------------------------
+
+-- | 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
+
+-- | '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
+
+-- | Auxiliary class for @'ToSourceIO' x ('SourceT' m x)@ instance.
+class SourceToSourceIO m where
+ sourceToSourceIO :: SourceT m a -> SourceT IO a
+
+instance SourceToSourceIO IO where
+ sourceToSourceIO = id
+
+-- | Relax to use auxiliary class, have m
+instance SourceToSourceIO m => ToSourceIO chunk (SourceT m chunk) where
+ toSourceIO = sourceToSourceIO
+
+instance ToSourceIO a (NonEmpty a) where
+ toSourceIO (x :| xs) = fromStepT (Yield x (foldr Yield Stop xs))
+
+instance ToSourceIO a [a] where
+ toSourceIO = source
+
+-- | '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 FramingUnrender NoFraming a where
- unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
- where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right)
-
--- | 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).
+instance FramingRender NoFraming where
+ framingRender _ = fmap
+
+-- | 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
+
+-------------------------------------------------------------------------------
+-- 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 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>
+instance FramingRender NewlineFraming where
+ framingRender _ f = fmap (\x -> f x <> "\n")
+
+instance FramingUnrender NewlineFraming where
+ framingUnrender _ f = transformWithAtto $ do
+ bs <- A.takeWhile (/= 10)
+ () <$ A.word8 10 <|> A.endOfInput
+ either fail pure (f (LBS.fromStrict bs))
+
+-------------------------------------------------------------------------------
+-- 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 FramingRender NetstringFraming a where
- header _ _ = empty
- boundary _ _ = BoundaryStrategyBracket $ \b -> ((<> ":") . LB.pack . show . LB.length $ b, ",")
- trailer _ _ = empty
-
-
-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))
diff --git a/src/Servant/API/TypeLevel.hs b/src/Servant/API/TypeLevel.hs
index 70968e4..188aa63 100644
--- a/src/Servant/API/TypeLevel.hs
+++ b/src/Servant/API/TypeLevel.hs
@@ -41,9 +41,6 @@ module Servant.API.TypeLevel (
-- ** 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 @@ import Servant.API.Sub
(type (:>))
import Servant.API.Verbs
(Verb)
-#if MIN_VERSION_base(4,9,0)
import GHC.TypeLits
(ErrorMessage (..), TypeError)
-#endif
@@ -222,14 +217,10 @@ type Elem e es = ElemGo e es es
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
@@ -244,12 +235,6 @@ type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We might try to factor these our more cleanly, but the type synonyms and type
diff --git a/src/Servant/API/Verbs.hs b/src/Servant/API/Verbs.hs
index f638160..b7d4c04 100644
--- a/src/Servant/API/Verbs.hs
+++ b/src/Servant/API/Verbs.hs
@@ -56,14 +56,17 @@ type Patch = Verb 'PATCH 200
-- 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
diff --git a/src/Servant/Links.hs b/src/Servant/Links.hs
index 812e22f..77f882d 100644
--- a/src/Servant/Links.hs
+++ b/src/Servant/Links.hs
@@ -170,7 +170,7 @@ import Servant.API.RemoteHost
import Servant.API.ReqBody
(ReqBody')
import Servant.API.Stream
- (Stream)
+ (Stream, StreamBody')
import Servant.API.Sub
(type (:>))
import Servant.API.TypeLevel
@@ -482,6 +482,10 @@ 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)
=> HasLink (Capture' mods sym v :> sub)
where
diff --git a/src/Servant/Test/ComprehensiveAPI.hs b/src/Servant/Test/ComprehensiveAPI.hs
new file mode 100644
index 0000000..51721c3
--- /dev/null
+++ b/src/Servant/Test/ComprehensiveAPI.hs
@@ -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
diff --git a/src/Servant/Types/SourceT.hs b/src/Servant/Types/SourceT.hs
new file mode 100644
index 0000000..284be4b
--- /dev/null
+++ b/src/Servant/Types/SourceT.hs
@@ -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)
diff --git a/src/Servant/Utils/Enter.hs b/src/Servant/Utils/Enter.hs
deleted file mode 100644
index 80c073c..0000000
--- a/src/Servant/Utils/Enter.hs
+++ /dev/null
@@ -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)
diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs
index 74bc09c..ecfcd7a 100644
--- a/test/Servant/API/ContentTypesSpec.hs
+++ b/test/Servant/API/ContentTypesSpec.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -11,26 +10,34 @@ module Servant.API.ContentTypesSpec where
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 @@ spec = describe "Servant.API.ContentTypes" $ do
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 @@ spec = describe "Servant.API.ContentTypes" $ do
-- 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 }
diff --git a/test/Servant/API/ResponseHeadersSpec.hs b/test/Servant/API/ResponseHeadersSpec.hs
index 02e54dd..4f2f418 100644
--- a/test/Servant/API/ResponseHeadersSpec.hs
+++ b/test/Servant/API/ResponseHeadersSpec.hs
@@ -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
diff --git a/test/Servant/API/StreamSpec.hs b/test/Servant/API/StreamSpec.hs
new file mode 100644
index 0000000..74eac52
--- /dev/null
+++ b/test/Servant/API/StreamSpec.hs
@@ -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)
diff --git a/test/Servant/LinksSpec.hs b/test/Servant/LinksSpec.hs
index 9cd5b0d..1c448ba 100644
--- a/test/Servant/LinksSpec.hs
+++ b/test/Servant/LinksSpec.hs
@@ -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 @@ spec = describe "Servant.Links" $ do
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` ""
-- |
diff --git a/test/Servant/Utils/EnterSpec.hs b/test/Servant/Utils/EnterSpec.hs
deleted file mode 100644
index 324bac0..0000000
--- a/test/Servant/Utils/EnterSpec.hs
+++ /dev/null
@@ -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 ()
diff --git a/test/doctests.hs b/test/doctests.hs
index 2d080e7..c27aa58 100644
--- a/test/doctests.hs
+++ b/test/doctests.hs
@@ -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