Hello community,
here is the log from the commit of package ghc-servant for openSUSE:Factory checked in at 2017-08-31 20:59:06
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-servant (Old)
and /work/SRC/openSUSE:Factory/.ghc-servant.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-servant"
Thu Aug 31 20:59:06 2017 rev:2 rq:513482 version:0.11
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-servant/ghc-servant.changes 2017-05-09 18:06:37.903371793 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-servant.new/ghc-servant.changes 2017-08-31 20:59:07.804936722 +0200
@@ -1,0 +2,5 @@
+Thu Jul 27 14:08:11 UTC 2017 - psimons@suse.com
+
+- Update to version 0.11 revision 1.
+
+-------------------------------------------------------------------
Old:
----
servant-0.9.1.1.tar.gz
New:
----
servant-0.11.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-servant.spec ++++++
--- /var/tmp/diff_new_pack.bMNkl4/_old 2017-08-31 20:59:09.000768704 +0200
+++ /var/tmp/diff_new_pack.bMNkl4/_new 2017-08-31 20:59:09.004768142 +0200
@@ -19,7 +19,7 @@
%global pkg_name servant
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.9.1.1
+Version: 0.11
Release: 0
Summary: A family of combinators for defining webservices APIs
License: BSD-3-Clause
@@ -32,20 +32,24 @@
BuildRequires: ghc-attoparsec-devel
BuildRequires: ghc-base-compat-devel
BuildRequires: ghc-bytestring-devel
+BuildRequires: ghc-cabal-doctest-devel
BuildRequires: ghc-case-insensitive-devel
BuildRequires: ghc-http-api-data-devel
BuildRequires: ghc-http-media-devel
BuildRequires: ghc-http-types-devel
BuildRequires: ghc-mmorph-devel
BuildRequires: ghc-mtl-devel
+BuildRequires: ghc-natural-transformation-devel
BuildRequires: ghc-network-uri-devel
BuildRequires: ghc-rpm-macros
BuildRequires: ghc-string-conversions-devel
+BuildRequires: ghc-tagged-devel
BuildRequires: ghc-text-devel
BuildRequires: ghc-vault-devel
BuildRoot: %{_tmppath}/%{name}-%{version}-build
%if %{with tests}
BuildRequires: ghc-QuickCheck-devel
+BuildRequires: ghc-aeson-compat-devel
BuildRequires: ghc-directory-devel
BuildRequires: ghc-doctest-devel
BuildRequires: ghc-filemanip-devel
++++++ servant-0.9.1.1.tar.gz -> servant-0.11.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/CHANGELOG.md new/servant-0.11/CHANGELOG.md
--- old/servant-0.9.1.1/CHANGELOG.md 2016-10-26 17:35:34.000000000 +0200
+++ new/servant-0.11/CHANGELOG.md 2017-05-24 09:22:24.000000000 +0200
@@ -1,3 +1,61 @@
+0.11
+----
+
+### Breaking changes
+
+- `Enter` refactored
+ ([#734](https://github.com/haskell-servant/servant/issues/734)
+ , [#736](https://github.com/haskell-servant/servant/pull/736))
+
+### Other changes
+
+- Add a type representing an empty API
+ ([#753](https://github.com/haskell-servant/servant/pull/753))
+- Add `linkURI'` and `Link` accessors
+ ([#745](https://github.com/haskell-servant/servant/pull/745)
+ , [#717](https://github.com/haskell-servant/servant/pull/717)
+ , [#715](https://github.com/haskell-servant/servant/issues/715))
+- Prepare for GHC-8.2
+ ([#722](https://github.com/haskell-servant/servant/pull/722))
+- Add `HasLink AuthProtect` instance
+ ([#720](https://github.com/haskell-servant/servant/pull/720))
+- `AllCTRender [] ()` `TypeError` (use `NoContent`)
+ ([#671](https://github.com/haskell-servant/servant/pull/671))
+- Documentation improvements and typo fixes
+ ([#702](https://github.com/haskell-servant/servant/pull/702)
+ , [#709](https://github.com/haskell-servant/servant/pull/709)
+ , [#716](https://github.com/haskell-servant/servant/pull/716)
+ , [#725](https://github.com/haskell-servant/servant/pull/725)
+ , [#727](https://github.com/haskell-servant/servant/pull/727))
+
+0.10
+----
+
+### Breaking changes
+
+* Use `NT` from `natural-transformation` for `Enter`
+ ([#616](https://github.com/haskell-servant/servant/issues/616))
+
+* Change to `MkLink (Verb ...) = Link` (previously `URI`). To consume `Link`
+ use its `ToHttpApiData` instance or `linkURI`.
+ ([#527](https://github.com/haskell-servant/servant/issues/527))
+
+### Other changes
+
+* Add `Servant.API.TypeLevel` module with type families to work with API types.
+ ([#345](https://github.com/haskell-servant/servant/pull/345)
+ , [#305](https://github.com/haskell-servant/servant/issues/305))
+
+* Default JSON content type change to `application/json;charset=utf-8`.
+ ([#263](https://github.com/haskell-servant/servant/issues/263))
+ Related browser bugs:
+ [Chromium](https://bugs.chromium.org/p/chromium/issues/detail?id=438464) and
+ [Firefox](https://bugzilla.mozilla.org/show_bug.cgi?id=918742)
+
+* `Accept` class may accept multiple content-types. `MimeUnrender` adopted as well.
+ ([#613](https://github.com/haskell-servant/servant/pull/614)
+ , [#615](https://github.com/haskell-servant/servant/pull/615))
+
0.9.1
------
@@ -14,6 +72,8 @@
----
* Add `CaptureAll` combinator. Captures all of the remaining segments in a URL.
+* Add `Servant.API.TypeLevel` module, with frequently used type-level
+functionaliy.
0.8
---
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/Setup.hs new/servant-0.11/Setup.hs
--- old/servant-0.9.1.1/Setup.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/Setup.hs 1970-01-01 01:00:00.000000000 +0100
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/Setup.lhs new/servant-0.11/Setup.lhs
--- old/servant-0.9.1.1/Setup.lhs 1970-01-01 01:00:00.000000000 +0100
+++ new/servant-0.11/Setup.lhs 2017-05-24 09:22:24.000000000 +0200
@@ -0,0 +1,31 @@
+\begin{code}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wall #-}
+module Main (main) where
+
+#ifndef MIN_VERSION_cabal_doctest
+#define MIN_VERSION_cabal_doctest(x,y,z) 0
+#endif
+
+#if MIN_VERSION_cabal_doctest(1,0,0)
+
+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
+main :: IO ()
+main = defaultMainWithDoctests "doctests"
+
+#else
+
+#ifdef MIN_VERSION_Cabal
+#warning You are configuring this package without cabal-doctest installed. \
+ The doctests test-suite will not work as a result. \
+ To fix this, install cabal-doctest before configuring.
+#endif
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
+
+#endif
+
+\end{code}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/servant.cabal new/servant-0.11/servant.cabal
--- old/servant-0.9.1.1/servant.cabal 2016-10-27 13:25:27.000000000 +0200
+++ new/servant-0.11/servant.cabal 2017-05-24 09:22:24.000000000 +0200
@@ -1,5 +1,5 @@
name: servant
-version: 0.9.1.1
+version: 0.11
synopsis: A family of combinators for defining webservices APIs
description:
A family of combinators for defining webservices APIs and serving them
@@ -14,8 +14,8 @@
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
-category: Web
-build-type: Simple
+category: Servant Web
+build-type: Custom
cabal-version: >=1.10
tested-with: GHC >= 7.8
extra-source-files:
@@ -25,6 +25,12 @@
type: git
location: http://github.com/haskell-servant/servant.git
+custom-setup
+ setup-depends:
+ base >= 4 && <5,
+ Cabal,
+ cabal-doctest >= 1.0.2 && <1.1
+
library
exposed-modules:
Servant.API
@@ -32,6 +38,7 @@
Servant.API.BasicAuth
Servant.API.Capture
Servant.API.ContentTypes
+ Servant.API.Empty
Servant.API.Experimental.Auth
Servant.API.Header
Servant.API.HttpVersion
@@ -43,6 +50,7 @@
Servant.API.ReqBody
Servant.API.ResponseHeaders
Servant.API.Sub
+ Servant.API.TypeLevel
Servant.API.Vault
Servant.API.Verbs
Servant.API.WithNamedContext
@@ -51,19 +59,26 @@
build-depends:
base >= 4.7 && < 4.10
, base-compat >= 0.9 && < 0.10
- , aeson >= 0.7 && < 1.1
+ , aeson >= 0.7 && < 1.3
, attoparsec >= 0.12 && < 0.14
, bytestring >= 0.10 && < 0.11
, case-insensitive >= 1.2 && < 1.3
, http-api-data >= 0.3 && < 0.4
, http-media >= 0.4 && < 0.7
, http-types >= 0.8 && < 0.10
+ , natural-transformation >= 0.4 && < 0.5
, mtl >= 2.0 && < 2.3
- , mmorph >= 1 && < 1.1
+ , mmorph >= 1 && < 1.2
+ , tagged >= 0.7.3 && < 0.9
, text >= 1 && < 1.3
, string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 && < 2.7
, vault >= 0.3 && < 0.4
+
+ if !impl(ghc >= 8.0)
+ build-depends:
+ semigroups >= 0.16 && < 0.19
+
hs-source-dirs: src
default-language: Haskell2010
other-extensions: CPP
@@ -101,10 +116,12 @@
Servant.API.ContentTypesSpec
Servant.API.ResponseHeadersSpec
Servant.Utils.LinksSpec
+ Servant.Utils.EnterSpec
build-depends:
base == 4.*
, base-compat
, aeson
+ , aeson-compat >=0.3.3 && <0.4
, attoparsec
, bytestring
, hspec == 2.*
@@ -115,6 +132,10 @@
, text
, url
+ if !impl(ghc >= 8.0)
+ build-depends:
+ semigroups >= 0.16 && < 0.19
+
test-suite doctests
build-depends: base
, servant
@@ -122,9 +143,14 @@
, filemanip
, directory
, filepath
+ , hspec
type: exitcode-stdio-1.0
- main-is: test/Doctests.hs
+ main-is: test/doctests.hs
buildable: True
default-language: Haskell2010
ghc-options: -Wall -threaded
+ if impl(ghc >= 8.2)
+ x-doctest-options: -fdiagnostics-color=never
include-dirs: include
+ x-doctest-source-dirs: test
+ x-doctest-modules: Servant.Utils.LinksSpec
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Alternative.hs new/servant-0.11/src/Servant/API/Alternative.hs
--- old/servant-0.9.1.1/src/Servant/API/Alternative.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/API/Alternative.hs 2017-05-24 09:22:24.000000000 +0200
@@ -7,6 +7,7 @@
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Alternative ((:<|>)(..)) where
+import Data.Semigroup (Semigroup (..))
import Data.Typeable (Typeable)
import Prelude ()
import Prelude.Compat
@@ -23,6 +24,9 @@
deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded)
infixr 8 :<|>
+instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where
+ (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b')
+
instance (Monoid a, Monoid b) => Monoid (a :<|> b) where
mempty = mempty :<|> mempty
(a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b')
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/ContentTypes.hs new/servant-0.11/src/Servant/API/ContentTypes.hs
--- old/servant-0.9.1.1/src/Servant/API/ContentTypes.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/API/ContentTypes.hs 2017-05-24 09:22:24.000000000 +0200
@@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -81,6 +82,7 @@
import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict)
import qualified Data.ByteString.Lazy.Char8 as BC
+import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.String.Conversions (cs)
import qualified Data.Text as TextS
@@ -96,6 +98,10 @@
import Prelude ()
import Prelude.Compat
+#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
@@ -119,10 +125,18 @@
--
class Accept ctype where
contentType :: Proxy ctype -> M.MediaType
+ contentType = NE.head . contentTypes
+
+ contentTypes :: Proxy ctype -> NE.NonEmpty M.MediaType
+ contentTypes = (NE.:| []) . contentType
+
+ {-# MINIMAL contentType | contentTypes #-}
-- | @application/json@
instance Accept JSON where
- contentType _ = "application" M.// "json"
+ contentTypes _ =
+ "application" M.// "json" M./: ("charset", "utf-8") NE.:|
+ [ "application" M.// "json" ]
-- | @application/x-www-form-urlencoded@
instance Accept FormUrlEncoded where
@@ -172,6 +186,12 @@
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
@@ -198,16 +218,32 @@
--
class Accept ctype => MimeUnrender ctype a where
mimeUnrender :: Proxy ctype -> ByteString -> Either String a
+ mimeUnrender p = mimeUnrenderWithType p (contentType p)
+
+ -- | Variant which is given the actual 'M.MediaType' provided by the other party.
+ --
+ -- In the most cases you don't want to branch based on the 'M.MediaType'.
+ -- See <https://github.com/haskell-servant/servant/pull/552 pr552> for a motivating example.
+ mimeUnrenderWithType :: Proxy ctype -> M.MediaType -> ByteString -> Either String a
+ mimeUnrenderWithType p _ = mimeUnrender p
+
+ {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
class AllCTUnrender (list :: [*]) a where
+ canHandleCTypeH
+ :: Proxy list
+ -> ByteString -- Content-Type header
+ -> Maybe (ByteString -> Either String a)
+
handleCTypeH :: Proxy list
-> ByteString -- Content-Type header
-> ByteString -- Request body
-> Maybe (Either String a)
+ handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
- handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
- where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
+ canHandleCTypeH p ctypeH =
+ M.mapContentMedia (allMimeUnrender p) (cs ctypeH)
--------------------------------------------------------------------------
-- * Utils (Internal)
@@ -219,9 +255,10 @@
allMime _ = []
instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
- allMime _ = (contentType pctyp):allMime pctyps
- where pctyp = Proxy :: Proxy ctyp
- pctyps = Proxy :: Proxy ctyps
+ allMime _ = NE.toList (contentTypes pctyp) ++ allMime pctyps
+ where
+ pctyp = Proxy :: Proxy ctyp
+ pctyps = Proxy :: Proxy ctyps
canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
@@ -235,25 +272,31 @@
-> [(M.MediaType, ByteString)] -- content-types/response pairs
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
- allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
- where pctyp = Proxy :: Proxy ctyp
+ allMimeRender _ a = map (, bs) $ NE.toList $ contentTypes pctyp
+ where
+ bs = mimeRender pctyp a
+ pctyp = Proxy :: Proxy ctyp
instance OVERLAPPABLE_
( MimeRender ctyp a
, AllMimeRender (ctyp' ': ctyps) a
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
- allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
- :(allMimeRender pctyps a)
- where pctyp = Proxy :: Proxy ctyp
- pctyps = Proxy :: Proxy (ctyp' ': ctyps)
+ allMimeRender _ a =
+ (map (, bs) $ NE.toList $ contentTypes pctyp)
+ ++ allMimeRender pctyps a
+ where
+ bs = mimeRender pctyp a
+ pctyp = Proxy :: Proxy ctyp
+ pctyps = Proxy :: Proxy (ctyp' ': ctyps)
-- 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
- allMimeRender _ _ = [(contentType pctyp, "")]
- where pctyp = Proxy :: Proxy ctyp
+ allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp
+ where
+ pctyp = Proxy :: Proxy ctyp
instance OVERLAPPING_
( AllMime (ctyp ': ctyp' ': ctyps)
@@ -265,19 +308,21 @@
--------------------------------------------------------------------------
class (AllMime list) => AllMimeUnrender (list :: [*]) a where
allMimeUnrender :: Proxy list
- -> ByteString
- -> [(M.MediaType, Either String a)]
+ -> [(M.MediaType, ByteString -> Either String a)]
instance AllMimeUnrender '[] a where
- allMimeUnrender _ _ = []
+ allMimeUnrender _ = []
instance ( MimeUnrender ctyp a
, AllMimeUnrender ctyps a
) => AllMimeUnrender (ctyp ': ctyps) a where
- allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
- :(allMimeUnrender pctyps val)
- where pctyp = Proxy :: Proxy ctyp
- pctyps = Proxy :: Proxy ctyps
+ allMimeUnrender _ =
+ (map mk $ NE.toList $ contentTypes pctyp)
+ ++ allMimeUnrender pctyps
+ where
+ mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)
+ pctyp = Proxy :: Proxy ctyp
+ pctyps = Proxy :: Proxy ctyps
--------------------------------------------------------------------------
-- * MimeRender Instances
@@ -374,6 +419,9 @@
-- $setup
+-- >>> :set -XFlexibleInstances
+-- >>> :set -XMultiParamTypeClasses
+-- >>> :set -XOverloadedStrings
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Empty.hs new/servant-0.11/src/Servant/API/Empty.hs
--- old/servant-0.9.1.1/src/Servant/API/Empty.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/servant-0.11/src/Servant/API/Empty.hs 2017-05-24 09:22:24.000000000 +0200
@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module Servant.API.Empty(EmptyAPI(..)) where
+
+import Data.Typeable (Typeable)
+import Prelude ()
+import Prelude.Compat
+
+-- | An empty API: one which serves nothing. Morally speaking, this should be
+-- the unit of ':<|>'. Implementors of interpretations of API types should
+-- treat 'EmptyAPI' as close to the unit as possible.
+data EmptyAPI = EmptyAPI deriving (Typeable, Eq, Show, Bounded, Enum)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/Internal/Test/ComprehensiveAPI.hs new/servant-0.11/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
--- old/servant-0.9.1.1/src/Servant/API/Internal/Test/ComprehensiveAPI.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/API/Internal/Test/ComprehensiveAPI.hs 2017-05-24 09:22:24.000000000 +0200
@@ -37,7 +37,8 @@
Verb 'POST 204 '[JSON] NoContent :<|>
Verb 'POST 204 '[JSON] Int :<|>
WithNamedContext "foo" '[] GET :<|>
- CaptureAll "foo" Int :> GET
+ CaptureAll "foo" Int :> GET :<|>
+ EmptyAPI
comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw
comprehensiveAPIWithoutRaw = Proxy
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/RemoteHost.hs new/servant-0.11/src/Servant/API/RemoteHost.hs
--- old/servant-0.9.1.1/src/Servant/API/RemoteHost.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/API/RemoteHost.hs 2017-05-24 09:22:24.000000000 +0200
@@ -12,7 +12,7 @@
-- $remotehost
--
--- | Use 'RemoteHost' whenever your request handlers need the host or IP address
+-- Use 'RemoteHost' whenever your request handlers need the host or IP address
-- from which the client issued the HTTP request. The corresponding handlers
-- receive arguments of type @SockAddr@ (from @Network.Socket@).
--
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/ResponseHeaders.hs new/servant-0.11/src/Servant/API/ResponseHeaders.hs
--- old/servant-0.9.1.1/src/Servant/API/ResponseHeaders.hs 2016-10-24 18:27:44.000000000 +0200
+++ new/servant-0.11/src/Servant/API/ResponseHeaders.hs 2017-05-24 09:22:24.000000000 +0200
@@ -45,7 +45,7 @@
import Prelude.Compat
-- | Response Header objects. You should never need to construct one directly.
--- Instead, use 'addOptionalHeader.
+-- Instead, use 'addOptionalHeader'.
data Headers ls a = Headers { getResponse :: a
-- ^ The underlying value of a 'Headers'
, getHeadersHList :: HList ls
@@ -125,7 +125,7 @@
-- | @addHeader@ adds a header to a response. Note that it changes the type of
-- the value in the following ways:
--
--- 1. A simple value is wrapped in "Headers [<hdr>]":
+-- 1. A simple value is wrapped in "Headers '[hdr]":
--
-- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String;
-- >>> getHeaders example1
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API/TypeLevel.hs new/servant-0.11/src/Servant/API/TypeLevel.hs
--- old/servant-0.9.1.1/src/Servant/API/TypeLevel.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/servant-0.11/src/Servant/API/TypeLevel.hs 2017-05-24 09:22:24.000000000 +0200
@@ -0,0 +1,264 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-|
+This module collects utilities for manipulating @servant@ API types. The
+functionality in this module is for advanced usage.
+
+The code samples in this module use the following type synonym:
+
+> type SampleAPI = "hello" :> Get '[JSON] Int
+> :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
+
+-}
+module Servant.API.TypeLevel (
+ -- $setup
+ -- * API predicates
+ Endpoints,
+ -- ** Lax inclusion
+ IsElem',
+ IsElem,
+ IsSubAPI,
+ AllIsElem,
+ -- ** Strict inclusion
+ IsIn,
+ IsStrictSubAPI,
+ AllIsIn,
+ -- * Helpers
+ -- ** Lists
+ MapSub,
+ AppendList,
+ IsSubList,
+ Elem,
+ ElemGo,
+ -- ** Logic
+ Or,
+ And,
+ -- * Custom type errors
+ -- | Before @base-4.9.0.0@ we use non-exported 'ElemNotFoundIn' class,
+ -- which cannot be instantiated.
+ ) where
+
+
+import GHC.Exts (Constraint)
+import Servant.API.Alternative (type (:<|>))
+import Servant.API.Capture (Capture, CaptureAll)
+import Servant.API.Header (Header)
+import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams)
+import Servant.API.ReqBody (ReqBody)
+import Servant.API.Sub (type (:>))
+import Servant.API.Verbs (Verb)
+#if MIN_VERSION_base(4,9,0)
+import GHC.TypeLits (TypeError, ErrorMessage(..))
+#endif
+
+
+
+-- * API predicates
+
+-- | Flatten API into a list of endpoints.
+--
+-- >>> Refl :: Endpoints SampleAPI :~: '["hello" :> Verb 'GET 200 '[JSON] Int, "bye" :> (Capture "name" String :> Verb 'POST 200 '[JSON, PlainText] Bool)]
+-- Refl
+type family Endpoints api where
+ Endpoints (a :<|> b) = AppendList (Endpoints a) (Endpoints b)
+ Endpoints (e :> a) = MapSub e (Endpoints a)
+ Endpoints a = '[a]
+
+-- ** Lax inclusion
+
+-- | You may use this type family to tell the type checker that your custom
+-- type may be skipped as part of a link. This is useful for things like
+-- @'QueryParam'@ that are optional in a URI and do not affect them if they are
+-- omitted.
+--
+-- >>> data CustomThing
+-- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s
+--
+-- Note that @'IsElem'@ is called, which will mutually recurse back to @'IsElem''@
+-- if it exhausts all other options again.
+--
+-- Once you have written a @HasLink@ instance for @CustomThing@ you are ready to go.
+type family IsElem' a s :: Constraint
+
+-- | Closed type family, check if @endpoint@ is within @api@.
+-- Uses @'IsElem''@ if it exhausts all other options.
+--
+-- >>> ok (Proxy :: Proxy (IsElem ("hello" :> Get '[JSON] Int) SampleAPI))
+-- OK
+--
+-- >>> ok (Proxy :: Proxy (IsElem ("bye" :> Get '[JSON] Int) SampleAPI))
+-- ...
+-- ... Could not deduce...
+-- ...
+--
+-- An endpoint is considered within an api even if it is missing combinators
+-- that don't affect the URL:
+--
+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
+-- OK
+--
+-- >>> ok (Proxy :: Proxy (IsElem (Get '[JSON] Int) (ReqBody '[JSON] Bool :> Get '[JSON] Int)))
+-- OK
+--
+-- *N.B.:* @IsElem a b@ can be seen as capturing the notion of whether the URL
+-- represented by @a@ would match the URL represented by @b@, *not* whether a
+-- request represented by @a@ matches the endpoints serving @b@ (for the
+-- latter, use 'IsIn').
+type family IsElem endpoint api :: Constraint where
+ IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
+ IsElem (e :> sa) (e :> sb) = IsElem sa sb
+ IsElem sa (Header sym x :> sb) = IsElem sa sb
+ IsElem sa (ReqBody y x :> sb) = IsElem sa sb
+ IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
+ = IsElem sa sb
+ IsElem (Capture z y :> sa) (Capture x y :> sb)
+ = IsElem sa sb
+ IsElem sa (QueryParam x y :> sb) = IsElem sa sb
+ IsElem sa (QueryParams x y :> sb) = IsElem sa sb
+ IsElem sa (QueryFlag x :> sb) = IsElem sa sb
+ IsElem (Verb m s ct typ) (Verb m s ct' typ)
+ = IsSubList ct ct'
+ IsElem e e = ()
+ IsElem e a = IsElem' e a
+
+-- | Check whether @sub@ is a sub-API of @api@.
+--
+-- >>> ok (Proxy :: Proxy (IsSubAPI SampleAPI (SampleAPI :<|> Get '[JSON] Int)))
+-- OK
+--
+-- >>> ok (Proxy :: Proxy (IsSubAPI (SampleAPI :<|> Get '[JSON] Int) SampleAPI))
+-- ...
+-- ... Could not deduce...
+-- ...
+--
+-- This uses @IsElem@ for checking; thus the note there applies here.
+type family IsSubAPI sub api :: Constraint where
+ IsSubAPI sub api = AllIsElem (Endpoints sub) api
+
+-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsElem'@).
+type family AllIsElem xs api :: Constraint where
+ AllIsElem '[] api = ()
+ AllIsElem (x ': xs) api = (IsElem x api, AllIsElem xs api)
+
+-- ** Strict inclusion
+
+-- | Closed type family, check if @endpoint@ is exactly within @api@.
+--
+-- >>> ok (Proxy :: Proxy (IsIn ("hello" :> Get '[JSON] Int) SampleAPI))
+-- OK
+--
+-- Unlike 'IsElem', this requires an *exact* match.
+--
+-- >>> ok (Proxy :: Proxy (IsIn (Get '[JSON] Int) (Header "h" Bool :> Get '[JSON] Int)))
+-- ...
+-- ... Could not deduce...
+-- ...
+type family IsIn (endpoint :: *) (api :: *) :: Constraint where
+ IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
+ IsIn (e :> sa) (e :> sb) = IsIn sa sb
+ IsIn e e = ()
+
+-- | Check whether @sub@ is a sub API of @api@.
+--
+-- Like 'IsSubAPI', but uses 'IsIn' rather than 'IsElem'.
+type family IsStrictSubAPI sub api :: Constraint where
+ IsStrictSubAPI sub api = AllIsIn (Endpoints sub) api
+
+-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).
+--
+-- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))
+-- OK
+type family AllIsIn xs api :: Constraint where
+ AllIsIn '[] api = ()
+ AllIsIn (x ': xs) api = (IsIn x api, AllIsIn xs api)
+
+-- * Helpers
+
+-- ** Lists
+
+-- | Apply @(e :>)@ to every API in @xs@.
+type family MapSub e xs where
+ MapSub e '[] = '[]
+ MapSub e (x ': xs) = (e :> x) ': MapSub e xs
+
+-- | Append two type-level lists.
+type family AppendList xs ys where
+ AppendList '[] ys = ys
+ AppendList (x ': xs) ys = x ': AppendList xs ys
+
+type family IsSubList a b :: Constraint where
+ IsSubList '[] b = ()
+ IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
+
+-- | Check that a value is an element of a list:
+--
+-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
+-- OK
+--
+-- >>> ok (Proxy :: Proxy (Elem String '[Int, Bool]))
+-- ...
+-- ... [Char]...'[Int, Bool...
+-- ...
+type Elem e es = ElemGo e es es
+
+-- 'orig' is used to store original list for better error messages
+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
+
+-- | If either a or b produce an empty constraint, produce an empty constraint.
+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
+ -- This works because of:
+ -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap
+ Or () b = ()
+ Or a () = ()
+
+-- | 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]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We might try to factor these our more cleanly, but the type synonyms and type
+families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
+-}
+
+
+-- $setup
+--
+-- The doctests in this module are run with following preamble:
+--
+-- >>> :set -XPolyKinds
+-- >>> :set -XGADTs
+-- >>> import Data.Proxy
+-- >>> import Data.Type.Equality
+-- >>> import Servant.API
+-- >>> data OK ctx where OK :: ctx => OK ctx
+-- >>> instance Show (OK ctx) where show _ = "OK"
+-- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK
+-- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
+-- >>> let sampleAPI = Proxy :: Proxy SampleAPI
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/API.hs new/servant-0.11/src/Servant/API.hs
--- old/servant-0.9.1.1/src/Servant/API.hs 2016-10-24 18:27:44.000000000 +0200
+++ new/servant-0.11/src/Servant/API.hs 2017-05-24 09:22:24.000000000 +0200
@@ -5,6 +5,8 @@
-- | Type-level combinator for expressing subrouting: @':>'@
module Servant.API.Alternative,
-- | Type-level combinator for alternative endpoints: @':<|>'@
+ module Servant.API.Empty,
+ -- | Type-level combinator for an empty API: @'EmptyAPI'@
-- * Accessing information from the request
module Servant.API.Capture,
@@ -66,6 +68,7 @@
MimeRender (..), NoContent (NoContent),
MimeUnrender (..), OctetStream,
PlainText)
+import Servant.API.Empty (EmptyAPI (..))
import Servant.API.Experimental.Auth (AuthProtect)
import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion (..))
@@ -101,7 +104,7 @@
ReflectMethod (reflectMethod),
Verb, StdMethod(..))
import Servant.API.WithNamedContext (WithNamedContext)
-import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
+import Servant.Utils.Links (HasLink (..), Link, IsElem, IsElem',
URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),
ToHttpApiData (..))
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/Utils/Enter.hs new/servant-0.11/src/Servant/Utils/Enter.hs
--- old/servant-0.9.1.1/src/Servant/Utils/Enter.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/Utils/Enter.hs 2017-05-24 09:22:24.000000000 +0200
@@ -8,9 +8,13 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-module Servant.Utils.Enter where
+module Servant.Utils.Enter (
+ module Servant.Utils.Enter,
+ -- * natural-transformation re-exports
+ (:~>)(..),
+ ) where
-import qualified Control.Category as C
+import Control.Natural
import Control.Monad.Identity
import Control.Monad.Morph
import Control.Monad.Reader
@@ -18,77 +22,101 @@
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 Data.Typeable
+import Data.Tagged (Tagged, retag)
import Prelude ()
import Prelude.Compat
-
import Servant.API
-class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
- enter :: arg -> typ -> ret
-
--- ** Servant combinators
-instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
- , arg1 ~ arg2
- ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where
+-- | 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 b arg ret) => Enter (a -> b) arg (a -> ret) where
+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)
--- ** Useful instances
-
--- | A natural transformation from @m@ to @n@. Used to `enter` particular
--- datatypes.
-newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable
-
-instance C.Category (:~>) where
- id = Nat id
- Nat f . Nat g = Nat (f . g)
+-- ** Leaf instances
-instance Enter (m a) (m :~> n) (n a) where
- enter (Nat f) = f
+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 = Nat Control.Monad.Morph.lift
+liftNat = NT Control.Monad.Morph.lift
runReaderTNat :: r -> (ReaderT r m :~> m)
-runReaderTNat a = Nat (`runReaderT` a)
+runReaderTNat a = NT (`runReaderT` a)
evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
-evalStateTLNat a = Nat (`LState.evalStateT` a)
+evalStateTLNat a = NT (`LState.evalStateT` a)
evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
-evalStateTSNat a = Nat (`SState.evalStateT` a)
+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 = Nat $ \x -> do
+logWriterTSNat logger = NT $ \x -> do
(a, w) <- SWriter.runWriterT x
liftIO $ logger w
return a
--- | Like `logWriterTSNat`, but for strict @WriterT@.
+-- | Like `logWriterTSNat`, but for lazy @WriterT@.
logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
-logWriterTLNat logger = Nat $ \x -> do
+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 (Nat n) = Nat $ hoist n
+hoistNat (NT n) = NT $ hoist n
-- | Like @mmorph@'s `embed`.
embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
-embedNat (Nat n) = Nat $ embed n
+embedNat (NT n) = NT $ embed n
-- | Like @mmorph@'s `squash`.
squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
-squashNat = Nat squash
+squashNat = NT squash
-- | Like @mmorph@'s `generalize`.
generalizeNat :: Applicative m => Identity :~> m
-generalizeNat = Nat (pure . runIdentity)
+generalizeNat = NT (pure . runIdentity)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/src/Servant/Utils/Links.hs new/servant-0.11/src/Servant/Utils/Links.hs
--- old/servant-0.9.1.1/src/Servant/Utils/Links.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/src/Servant/Utils/Links.hs 2017-05-24 09:22:24.000000000 +0200
@@ -6,7 +6,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Type safe generation of internal links.
@@ -30,7 +29,7 @@
-- you would like to restrict links to. The second argument is the destination
-- endpoint you would like the link to point to, this will need to end with a
-- verb like GET or POST. Further arguments may be required depending on the
--- type of the endpoint. If everything lines up you will get a 'URI' out the
+-- type of the endpoint. If everything lines up you will get a 'Link' out the
-- other end.
--
-- You may omit 'QueryParam's and the like should you not want to provide them,
@@ -41,19 +40,19 @@
-- with an example. Here, a link is generated with no parameters:
--
-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
--- >>> print (safeLink api hello :: URI)
--- hello
+-- >>> toUrlPiece (safeLink api hello :: Link)
+-- "hello"
--
-- If the API has an endpoint with parameters then we can generate links with
-- or without those:
--
-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
--- >>> print $ safeLink api with (Just "Hubert")
--- bye?name=Hubert
+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
+-- "bye?name=Hubert"
--
-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
--- >>> print $ safeLink api without
--- bye
+-- >>> toUrlPiece $ safeLink api without
+-- "bye"
--
-- If you would like create a helper for generating links only within that API,
-- you can partially apply safeLink if you specify a correct type signature
@@ -79,27 +78,30 @@
-- bad_link under api after trying the open (but empty) type family
-- `IsElem'` as a last resort.
module Servant.Utils.Links (
+ module Servant.API.TypeLevel,
+
-- * Building and using safe links
--
- -- | Note that 'URI' is Network.URI.URI from the network-uri package.
+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
safeLink
, URI(..)
-- * Adding custom types
, HasLink(..)
- , linkURI
, Link
- , IsElem'
- -- * Illustrative exports
- , IsElem
- , Or
+ , linkURI
+ , linkURI'
+ , LinkArrayElementStyle (..)
+ -- ** Link accessors
+ , Param (..)
+ , linkSegments
+ , linkQueryParams
) where
-import qualified Data.ByteString.Char8 as BSC
import Data.List
import Data.Monoid.Compat ( (<>) )
import Data.Proxy ( Proxy(..) )
import qualified Data.Text as Text
-import GHC.Exts (Constraint)
+import qualified Data.Text.Encoding as TE
import GHC.TypeLits ( KnownSymbol, symbolVal )
import Network.URI ( URI(..), escapeURIString, isUnreserved )
import Prelude ()
@@ -115,77 +117,31 @@
import Servant.API.Verbs ( Verb )
import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw )
-import Servant.API.Alternative ( type (:<|>) )
+import Servant.API.TypeLevel
+import Servant.API.Experimental.Auth ( AuthProtect )
-- | A safe link datatype.
-- The only way of constructing a 'Link' is using 'safeLink', which means any
-- 'Link' is guaranteed to be part of the mentioned API.
data Link = Link
- { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]
- , _queryParams :: [Param Query]
+ { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]
+ , _queryParams :: [Param]
} deriving Show
-instance ToHttpApiData Link where
- toUrlPiece = Text.pack . show
- toHeader = BSC.pack . show
+linkSegments :: Link -> [String]
+linkSegments = _segments
--- | If either a or b produce an empty constraint, produce an empty constraint.
-type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
- -- This works because of:
- -- https://ghc.haskell.org/trac/ghc/wiki/NewAxioms/CoincidentOverlap
- Or () b = ()
- Or a () = ()
-
--- | If both a or b produce an empty constraint, produce an empty constraint.
-type family And (a :: Constraint) (b :: Constraint) :: Constraint where
- And () () = ()
-
--- | You may use this type family to tell the type checker that your custom
--- type may be skipped as part of a link. This is useful for things like
--- 'QueryParam' that are optional in a URI and do not affect them if they are
--- omitted.
---
--- >>> data CustomThing
--- >>> type instance IsElem' e (CustomThing :> s) = IsElem e s
---
--- Note that 'IsElem' is called, which will mutually recurse back to `IsElem'`
--- if it exhausts all other options again.
---
--- Once you have written a HasLink instance for CustomThing you are ready to
--- go.
-type family IsElem' a s :: Constraint
-
--- | Closed type family, check if endpoint is within api
-type family IsElem endpoint api :: Constraint where
- IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
- IsElem (e :> sa) (e :> sb) = IsElem sa sb
- IsElem sa (Header sym x :> sb) = IsElem sa sb
- IsElem sa (ReqBody y x :> sb) = IsElem sa sb
- IsElem (Capture z y :> sa) (Capture x y :> sb)
- = IsElem sa sb
- IsElem (CaptureAll z y :> sa) (CaptureAll x y :> sb)
- = IsElem sa sb
- IsElem sa (QueryParam x y :> sb) = IsElem sa sb
- IsElem sa (QueryParams x y :> sb) = IsElem sa sb
- IsElem sa (QueryFlag x :> sb) = IsElem sa sb
- IsElem (Verb m s ct typ) (Verb m s ct' typ)
- = IsSubList ct ct'
- IsElem e e = ()
- IsElem e a = IsElem' e a
-
-type family IsSubList a b :: Constraint where
- IsSubList '[] b = ()
- IsSubList (x ': xs) y = Elem x y `And` IsSubList xs y
-
-type family Elem e es :: Constraint where
- Elem x (x ': xs) = ()
- Elem y (x ': xs) = Elem y xs
+linkQueryParams :: Link -> [Param]
+linkQueryParams = _queryParams
--- Phantom types for Param
-data Query
+instance ToHttpApiData Link where
+ toHeader = TE.encodeUtf8 . toUrlPiece
+ toUrlPiece l =
+ let uri = linkURI l
+ in Text.pack $ uriPath uri ++ uriQuery uri
--- | Query param
-data Param a
+-- | Query parameter.
+data Param
= SingleParam String Text.Text
| ArrayElemParam String Text.Text
| FlagParam String
@@ -194,27 +150,63 @@
addSegment :: String -> Link -> Link
addSegment seg l = l { _segments = _segments l <> [seg] }
-addQueryParam :: Param Query -> Link -> Link
+addQueryParam :: Param -> Link -> Link
addQueryParam qp l =
l { _queryParams = _queryParams l <> [qp] }
+-- | Transform 'Link' into 'URI'.
+--
+-- >>> type API = "something" :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
+-- something
+--
+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x[]=1&x[]=2&x[]=3
+--
+-- >>> type API = "foo/bar" :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
+-- foo%2Fbar
+--
linkURI :: Link -> URI
-linkURI (Link segments q_params) =
+linkURI = linkURI' LinkArrayElementBracket
+
+-- | How to encode array query elements.
+data LinkArrayElementStyle
+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | Configurable 'linkURI'.
+--
+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x[]=1&x[]=2&x[]=3
+--
+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x=1&x=2&x=3
+--
+linkURI' :: LinkArrayElementStyle -> Link -> URI
+linkURI' addBrackets (Link segments q_params) =
URI mempty -- No scheme (relative)
Nothing -- Or authority (relative)
- (intercalate "/" segments)
+ (intercalate "/" $ map escape segments)
(makeQueries q_params) mempty
where
- makeQueries :: [Param Query] -> String
+ makeQueries :: [Param] -> String
makeQueries [] = ""
makeQueries xs =
"?" <> intercalate "&" (fmap makeQuery xs)
- makeQuery :: Param Query -> String
- makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v)
+ makeQuery :: Param -> String
+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
makeQuery (FlagParam k) = escape k
+ style = case addBrackets of
+ LinkArrayElementBracket -> "[]="
+ LinkArrayElementPlain -> "="
+
escape :: String -> String
escape = escapeURIString isUnreserved
@@ -307,9 +299,17 @@
-- Verb (terminal) instances
instance HasLink (Verb m s ct a) where
- type MkLink (Verb m s ct a) = URI
- toLink _ = linkURI
+ type MkLink (Verb m s ct a) = Link
+ toLink _ = id
instance HasLink Raw where
- type MkLink Raw = URI
- toLink _ = linkURI
+ type MkLink Raw = Link
+ toLink _ = id
+
+-- AuthProtext instances
+instance HasLink sub => HasLink (AuthProtect tag :> sub) where
+ type MkLink (AuthProtect tag :> sub) = MkLink sub
+ toLink _ = toLink (Proxy :: Proxy sub)
+
+-- $setup
+-- >>> import Servant.API
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Doctests.hs new/servant-0.11/test/Doctests.hs
--- old/servant-0.9.1.1/test/Doctests.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/test/Doctests.hs 1970-01-01 01:00:00.000000000 +0100
@@ -1,40 +0,0 @@
-module Main where
-
-import Data.List (isPrefixOf)
-import System.Directory
-import System.FilePath
-import System.FilePath.Find
-import Test.DocTest
-
-main :: IO ()
-main = do
- files <- find always (extension ==? ".hs") "src"
- tfiles <- find always (extension ==? ".hs") "test/Servant"
- mCabalMacrosFile <- getCabalMacrosFile
- doctest $ "-isrc" : "-Iinclude" :
- (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
- "-XOverloadedStrings" :
- "-XFlexibleInstances" :
- "-XMultiParamTypeClasses" :
- (files ++ tfiles)
-
-getCabalMacrosFile :: IO (Maybe FilePath)
-getCabalMacrosFile = do
- exists <- doesDirectoryExist "dist"
- if exists
- then do
- contents <- getDirectoryContents "dist"
- let rest = "build" "autogen" "cabal_macros.h"
- whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
- [x] -> "dist" x rest
- [] -> "dist" rest
- xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
- ++ show xs ++ "\nTry cabal clean"
- else return Nothing
- where
- whenExists :: FilePath -> IO (Maybe FilePath)
- whenExists file = do
- exists <- doesFileExist file
- return $ if exists
- then Just file
- else Nothing
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/API/ContentTypesSpec.hs new/servant-0.11/test/Servant/API/ContentTypesSpec.hs
--- old/servant-0.9.1.1/test/Servant/API/ContentTypesSpec.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/test/Servant/API/ContentTypesSpec.hs 2017-05-24 09:22:24.000000000 +0200
@@ -11,21 +11,25 @@
import Prelude ()
import Prelude.Compat
-import Data.Aeson
+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.Either
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 GHC.Generics
import Test.Hspec
import Test.QuickCheck
+import Text.Read (readMaybe)
import "quickcheck-instances" Test.QuickCheck.Instances ()
import Servant.API.ContentTypes
@@ -101,23 +105,31 @@
"application/octet-stream" ("content" :: ByteString)
`shouldSatisfy` isJust
+ it "returns Just if the 'Accept' header matches, with multiple mime types" $ do
+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "application/json" (3 :: Int)
+ `shouldSatisfy` isJust
+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "text/plain" (3 :: Int)
+ `shouldSatisfy` isJust
+ handleAcceptH (Proxy :: Proxy '[JSONorText]) "image/jpeg" (3 :: Int)
+ `shouldBe` Nothing
+
it "returns the Content-Type as the first element of the tuple" $ do
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
- `shouldSatisfy` ((== "application/json") . fst . fromJust)
+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int)
- `shouldSatisfy` ((== "application/json") . fst . fromJust)
+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream])
"application/octet-stream" ("content" :: ByteString)
`shouldSatisfy` ((== "application/octet-stream") . fst . fromJust)
it "returns the appropriately serialized representation" $ do
property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData)
- == Just ("application/json", encode x)
+ == Just ("application/json;charset=utf-8", encode x)
it "respects the Accept spec ordering" $ do
let highest a b c = maximumBy (compare `on` snd)
[ ("application/octet-stream", a)
- , ("application/json", b)
+ , ("application/json;charset=utf-8", b)
, ("text/plain;charset=utf-8", c)
]
let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $
@@ -158,6 +170,24 @@
(encode val)
`shouldBe` Just (Right val)
+ it "returns Just (Right val) if the decoding succeeds for either of multiple mime-types" $ do
+ let val = 42 :: Int
+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"
+ "42" `shouldBe` Just (Right val)
+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"
+ "42" `shouldBe` Just (Right val)
+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "image/jpeg"
+ "42" `shouldBe` (Nothing :: Maybe (Either String Int))
+
+ it "passes content-type to mimeUnrenderWithType" $ do
+ let val = "foobar" :: TextS.Text
+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "application/json"
+ "\"foobar\"" `shouldBe` Just (Right val)
+ handleCTypeH (Proxy :: Proxy '[JSONorText]) "text/plain"
+ "foobar" `shouldBe` Just (Right val)
+ 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
@@ -201,6 +231,23 @@
instance IsString AcceptHeader where
fromString = AcceptHeader . fromString
+-- To test multiple content types
+data JSONorText
+
+instance Accept JSONorText where
+ contentTypes _ = "text/plain" NE.:| [ "application/json" ]
+
+instance MimeRender JSONorText Int where
+ mimeRender _ = cs . show
+
+instance MimeUnrender JSONorText Int where
+ mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack
+
+instance MimeUnrender JSONorText TextS.Text where
+ mimeUnrenderWithType _ mt
+ | mt == "application/json" = maybe (Left "") Right . decode
+ | otherwise = Right . TextSE.decodeUtf8 . BSL.toStrict
+
addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/Utils/EnterSpec.hs new/servant-0.11/test/Servant/Utils/EnterSpec.hs
--- old/servant-0.9.1.1/test/Servant/Utils/EnterSpec.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/servant-0.11/test/Servant/Utils/EnterSpec.hs 2017-05-24 09:22:24.000000000 +0200
@@ -0,0 +1,32 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/Servant/Utils/LinksSpec.hs new/servant-0.11/test/Servant/Utils/LinksSpec.hs
--- old/servant-0.9.1.1/test/Servant/Utils/LinksSpec.hs 2016-10-24 17:04:42.000000000 +0200
+++ new/servant-0.11/test/Servant/Utils/LinksSpec.hs 2017-05-24 09:22:24.000000000 +0200
@@ -7,6 +7,7 @@
import Data.Proxy (Proxy (..))
import Test.Hspec (Expectation, Spec, describe, it,
shouldBe)
+import Data.String (fromString)
import Servant.API
@@ -24,6 +25,7 @@
:<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] NoContent
:<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent
:<|> "raw" :> Raw
+ :<|> NoEndpoint
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
@@ -32,47 +34,49 @@
-- | Convert a link to a URI and ensure that this maps to the given string
-- given string
-shouldBeURI :: URI -> String -> Expectation
-shouldBeURI link expected =
- show link `shouldBe` expected
+shouldBeLink :: Link -> String -> Expectation
+shouldBeLink link expected =
+ toUrlPiece link `shouldBe` fromString expected
spec :: Spec
spec = describe "Servant.Utils.Links" $ do
it "generates correct links for capture query params" $ do
let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)
- apiLink l1 "hi" `shouldBeURI` "hello/hi"
+ apiLink l1 "hi" `shouldBeLink` "hello/hi"
let l2 = Proxy :: Proxy ("hello" :> Capture "name" String
:> QueryParam "capital" Bool
:> Delete '[JSON] NoContent)
- apiLink l2 "bye" (Just True) `shouldBeURI` "hello/bye?capital=true"
+ apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true"
it "generates correct links for CaptureAll" $ do
apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent))
["roads", "lead", "to", "rome"]
- `shouldBeURI` "all/roads/lead/to/rome"
+ `shouldBeLink` "all/roads/lead/to/rome"
it "generates correct links for query flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
:> QueryFlag "fast" :> Delete '[JSON] NoContent)
- apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"
- apiLink l1 False True `shouldBeURI` "balls?fast"
+ apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"
+ apiLink l1 False True `shouldBeLink` "balls?fast"
it "generates correct links for all of the verbs" $ do
- apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeURI` "get"
- apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeURI` "put"
- apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeURI` "post"
- apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeURI` "delete"
- apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"
+ apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"
+ apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"
+ apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post"
+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete"
+ apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw"
-- |
-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
-- we'll just use doctest
--
+-- with TypeError comparing for errors is difficult.
+--
-- >>> apiLink (Proxy :: Proxy WrongPath)
-- ...
--- ...Could not deduce...
+-- ......:...:...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongReturnType)
@@ -82,7 +86,7 @@
--
-- >>> apiLink (Proxy :: Proxy WrongContentType)
-- ...
--- ...Could not deduce...
+-- ......:...:...
-- ...
--
-- >>> apiLink (Proxy :: Proxy WrongMethod)
@@ -95,12 +99,18 @@
-- ...Could not deduce...
-- ...
--
+-- >>> apiLink (Proxy :: Proxy NoEndpoint)
+-- ...
+-- ...No instance for...
+-- ...
+--
-- sanity check
--- >>> apiLink (Proxy :: Proxy AllGood)
--- get
+-- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood)
+-- "get"
type WrongPath = "getTypo" :> Get '[JSON] NoContent
type WrongReturnType = "get" :> Get '[JSON] Bool
type WrongContentType = "get" :> Get '[OctetStream] NoContent
type WrongMethod = "get" :> Post '[JSON] NoContent
type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool
type AllGood = "get" :> Get '[JSON] NoContent
+type NoEndpoint = "empty" :> EmptyAPI
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-0.9.1.1/test/doctests.hs new/servant-0.11/test/doctests.hs
--- old/servant-0.9.1.1/test/doctests.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/servant-0.11/test/doctests.hs 2017-05-24 09:22:24.000000000 +0200
@@ -0,0 +1,25 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Main (doctests)
+-- Copyright : (C) 2012-14 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett