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 <ekmett@gmail.com> +-- Stability : provisional +-- Portability : portable +-- +-- This module provides doctests for a project based on the actual versions +-- of the packages it was built with. It requires a corresponding Setup.lhs +-- to be added to the project +----------------------------------------------------------------------------- +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources ++++++ servant.cabal ++++++ --- /var/tmp/diff_new_pack.bMNkl4/_old 2017-08-31 20:59:09.676673737 +0200 +++ /var/tmp/diff_new_pack.bMNkl4/_new 2017-08-31 20:59:09.688672052 +0200 @@ -1,5 +1,5 @@ name: servant -version: 0.9.1.1 +version: 0.11 x-revision: 1 synopsis: A family of combinators for defining webservices APIs description: @@ -15,8 +15,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: @@ -26,6 +26,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 @@ -33,6 +39,7 @@ Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes + Servant.API.Empty Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion @@ -44,27 +51,35 @@ Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub + Servant.API.TypeLevel Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext Servant.Utils.Links Servant.Utils.Enter build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 4.11 , base-compat >= 0.9 && < 0.10 - , aeson >= 0.7 && < 1.2 + , 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-media >= 0.4 && < 0.8 , 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 @@ -102,10 +117,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.* @@ -116,6 +133,10 @@ , text , url + if !impl(ghc >= 8.0) + build-depends: + semigroups >= 0.16 && < 0.19 + test-suite doctests build-depends: base , servant @@ -123,9 +144,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