servant 0.20.1 → 0.20.2

raw patch · 32 files changed

+501/−281 lines, 32 filesdep +containersdep −base-compatdep −string-conversionsdep −taggeddep ~basedep ~transformersnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers

Dependencies removed: base-compat, string-conversions, tagged

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +34/−0
• servant.cabal +107/−92
• src/Servant/API.hs +7/−2
• src/Servant/API/Alternative.hs +4/−7
• src/Servant/API/BasicAuth.hs +4/−2
• src/Servant/API/Capture.hs +4/−2
• src/Servant/API/ContentTypes.hs +10/−13
• src/Servant/API/Description.hs +3/−1
• src/Servant/API/Empty.hs +1/−4
• src/Servant/API/Experimental/Auth.hs +1/−1
• src/Servant/API/Fragment.hs +4/−2
• src/Servant/API/Generic.hs +4/−1
• src/Servant/API/Header.hs +3/−1
• src/Servant/API/Modifiers.hs +6/−3
• src/Servant/API/NamedRoutes.hs +3/−1
• src/Servant/API/QueryParam.hs +5/−3
• src/Servant/API/QueryString.hs +86/−0
• src/Servant/API/ReqBody.hs +3/−1
• src/Servant/API/ResponseHeaders.hs +36/−36
• src/Servant/API/Stream.hs +6/−4
• src/Servant/API/Sub.hs +3/−1
• src/Servant/API/TypeErrors.hs +1/−1
• src/Servant/API/TypeLevel.hs +24/−15
• src/Servant/API/UVerb.hs +8/−7
• src/Servant/API/UVerb/Union.hs +5/−4
• src/Servant/API/Verbs.hs +4/−2
• src/Servant/API/WithNamedContext.hs +3/−1
• src/Servant/Links.hs +27/−40
• src/Servant/Types/SourceT.hs +10/−15
• test/Servant/API/ContentTypesSpec.hs +12/−18
• test/Servant/API/ResponseHeadersSpec.hs +8/−0
• test/Servant/LinksSpec.hs +65/−1

@@ -2,6 +2,40 @@  Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20.2+----+- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604)++  This PR introduces `DeepQuery`, a route combinator that implements a pattern commonly known as deep objects.+  It builds upon the convention of using `[]` for a list of parameters: +  `books?filter[search]=value&filter[author][name]=value`.+  The corresponding type would be `DeepQuery "filter" BookQuery :> Get '[JSON] [Book]`.+- Add IsIn instance for NamedRoutes [#1707](https://github.com/haskell-servant/servant/pull/1707)+- Renamed `AtLeastOneFragment` type class to `AtMostOneFragment` [#1727](https://github.com/haskell-servant/servant/pull/1727)++  The previously named `AtLeastOneFragment` type class defined in the+  `Servant.API.TypeLevel` module has been renamed to `AtMostOneFragment`,+  since the previous name was misleading.+- Use `Header'` in response headers. [#1697](https://github.com/haskell-servant/servant/pull/1697)++  Use `Header'` instead of `Header` in response, so it's possible to provide+  `Description`, for example:++  ```+  type PaginationTotalCountHeader =+    Header'+      '[ Description "Indicates to the client total count of items in collection"+       , Optional+       , Strict+       ]+      "Total-Count"+      Int+  ```++  Note: if you want to add header with description you should use `addHeader'`+  or `noHeader'` which accepts `Header'` with all modifiers.++ 0.20.1 ---- 

@@ -1,9 +1,8 @@-cabal-version:       2.2-name:                servant-version:             0.20.1--synopsis:            A family of combinators for defining webservices APIs-category:            Servant, Web+cabal-version:      3.0+name:               servant+version:            0.20.2+synopsis:           A family of combinators for defining webservices APIs+category:           Servant, Web description:   A family of combinators for defining webservices APIs and serving them   .@@ -11,26 +10,75 @@   .   <https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md CHANGELOG> -homepage:            http://docs.servant.dev/-bug-reports:         http://github.com/haskell-servant/servant/issues-license:             BSD-3-Clause-license-file:        LICENSE-author:              Servant Contributors-maintainer:          haskell-servant-maintainers@googlegroups.com-copyright:           2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors-build-type:          Simple+homepage:           http://docs.servant.dev/+bug-reports:        http://github.com/haskell-servant/servant/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Servant Contributors+maintainer:         haskell-servant-maintainers@googlegroups.com+copyright:+  2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors -tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4-           , GHCJS ==8.6.0.1+build-type:         Simple+tested-with:+  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1 -extra-source-files:-  CHANGELOG.md+extra-source-files: CHANGELOG.md  source-repository head-  type: git+  type:     git   location: http://github.com/haskell-servant/servant.git +common extensions+  default-extensions:+    AllowAmbiguousTypes+    ConstraintKinds+    DataKinds+    DeriveAnyClass+    DeriveDataTypeable+    DeriveFunctor+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    ExplicitNamespaces+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    InstanceSigs+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    NoStarIsType+    OverloadedLabels+    OverloadedStrings+    PackageImports+    PolyKinds+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StrictData+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UndecidableInstances+    ViewPatterns++  default-language:   Haskell2010++common ghc-options+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+    -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+    -Wno-unticked-promoted-constructors -Werror=unused-imports+    -Wunused-packages+ library+  import:          extensions+  import:          ghc-options   exposed-modules:     Servant.API     Servant.API.Alternative@@ -48,6 +96,7 @@     Servant.API.Modifiers     Servant.API.NamedRoutes     Servant.API.QueryParam+    Servant.API.QueryString     Servant.API.Raw     Servant.API.RemoteHost     Servant.API.ReqBody@@ -65,111 +114,77 @@     Servant.API.WithResource    -- Types-  exposed-modules:-    Servant.Types.SourceT+  exposed-modules: Servant.Types.SourceT    -- Test stuff-  exposed-modules:-    Servant.Test.ComprehensiveAPI+  exposed-modules: Servant.Test.ComprehensiveAPI    -- Safe links-  exposed-modules:-    Servant.Links+  exposed-modules: Servant.Links    -- Bundled with GHC: Lower bound to not force re-installs   -- text and mtl are bundled starting with GHC-8.4   --   -- note: mtl lower bound is so low because of GHC-7.8   build-depends:-      base                   >= 4.9      && < 4.19-    , bytestring             >= 0.10.8.1 && < 0.12-    , constraints            >= 0.2-    , mtl                    ^>= 2.2.2   || ^>= 2.3.1-    , sop-core               >= 0.4.0.0  && < 0.6-    , transformers           >= 0.5.2.0  && < 0.7-    , text                   >= 1.2.3.0  && < 2.1-+    , base          >=4.14     && <4.21+    , bytestring    >=0.10.8.1 && <0.13+    , constraints   >=0.2+    , containers    >=0.6      && <0.8+    , mtl           ^>=2.2.2   || ^>=2.3.1+    , sop-core      >=0.4.0.0  && <0.6+    , text          >=1.2.3.0  && <2.2+    , transformers  >=0.5.2.0  && <0.7    -- We depend (heavily) on the API of these packages:   -- i.e. re-export, or allow using without direct dependency   build-depends:-      http-api-data          >= 0.4.1    && < 0.7-    , singleton-bool         >= 0.1.4    && < 0.2+    , http-api-data   >=0.4.1 && <0.7+    , singleton-bool  >=0.1.4 && <0.2    -- Other dependencies: Lower bound around what is in the latest Stackage LTS.   -- Here can be exceptions if we really need features from the newer versions.   build-depends:-      base-compat            >= 0.10.5   && < 0.14-    , aeson                  >= 1.4.1.0  && < 2.3-    , attoparsec             >= 0.13.2.2 && < 0.15-    , bifunctors             >= 5.5.3    && < 5.7-    , case-insensitive       >= 1.2.0.11 && < 1.3-    , deepseq                >= 1.4.2.0  && < 1.5-    , http-media             >= 0.7.1.3  && < 0.9-    , http-types             >= 0.12.2   && < 0.13-    , mmorph                 >= 1.1.2    && < 1.3-    , network-uri            >= 2.6.1.0  && < 2.7-    , QuickCheck             >= 2.12.6.1 && < 2.15-    , string-conversions     >= 0.4.0.1  && < 0.5-    , tagged                 >= 0.8.6    && < 0.9-    , vault                  >= 0.3.1.2  && < 0.4--  hs-source-dirs: src-  default-language: Haskell2010-  other-extensions: AllowAmbiguousTypes-                  , CPP-                  , ConstraintKinds-                  , DataKinds-                  , DeriveDataTypeable-                  , DeriveGeneric-                  , ExplicitNamespaces-                  , FlexibleContexts-                  , FlexibleInstances-                  , FunctionalDependencies-                  , GADTs-                  , KindSignatures-                  , MultiParamTypeClasses-                  , OverloadedStrings-                  , PolyKinds-                  , RankNTypes-                  , ScopedTypeVariables-                  , TupleSections-                  , TypeFamilies-                  , TypeOperators-                  , UndecidableInstances+    , aeson             >=1.4.1.0  && <2.3+    , attoparsec        >=0.13.2.2 && <0.15+    , bifunctors        >=5.5.3    && <5.7+    , case-insensitive  >=1.2.0.11 && <1.3+    , deepseq           >=1.4.2.0  && <1.6+    , http-media        >=0.7.1.3  && <0.9+    , http-types        >=0.12.2   && <0.13+    , mmorph            >=1.1.2    && <1.3+    , network-uri       >=2.6.1.0  && <2.7+    , QuickCheck        >=2.12.6.1 && <2.16+    , vault             >=0.3.1.2  && <0.4 -  ghc-options: -Wall -Wno-redundant-constraints+  hs-source-dirs:  src  test-suite spec-  type: exitcode-stdio-1.0-  ghc-options: -Wall-  default-language: Haskell2010-  hs-source-dirs: test-  main-is: Spec.hs+  import:             extensions+  import:             ghc-options+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Spec.hs   other-modules:-      Servant.API.ContentTypesSpec-      Servant.API.ResponseHeadersSpec-      Servant.API.StreamSpec-      Servant.LinksSpec+    Servant.API.ContentTypesSpec+    Servant.API.ResponseHeadersSpec+    Servant.API.StreamSpec+    Servant.LinksSpec    -- Dependencies inherited from the library. No need to specify bounds.   build-depends:-      base-    , base-compat     , aeson+    , base     , bytestring     , http-media     , mtl     , servant-    , string-conversions     , text-    , transformers    -- Additional dependencies   build-depends:-      hspec                >= 2.6.0    && < 2.12-    , QuickCheck           >= 2.12.6.1 && < 2.15-    , quickcheck-instances >= 0.3.19   && < 0.4+    , hspec                 >=2.6.0    && <2.12+    , QuickCheck            >=2.12.6.1 && <2.16+    , quickcheck-instances  >=0.3.19   && <0.4 -  build-tool-depends:-    hspec-discover:hspec-discover >= 2.6.0 && < 2.12+  build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12

@@ -19,6 +19,8 @@   -- | Retrieving the HTTP version of the request   module Servant.API.QueryParam,   -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@+  module Servant.API.QueryString,+  -- | Retrieving the complete query string of the 'URI': @'QueryString'@   module Servant.API.Fragment,   -- | Documenting the fragment of the 'URI': @'Fragment'@   module Servant.API.ReqBody,@@ -118,6 +120,8 @@                  (NamedRoutes) import           Servant.API.QueryParam                  (QueryFlag, QueryParam, QueryParam', QueryParams)+import           Servant.API.QueryString+                 (QueryString, DeepQuery) import           Servant.API.Raw                  (Raw, RawM) import           Servant.API.RemoteHost@@ -127,8 +131,9 @@ import           Servant.API.ResponseHeaders                  (AddHeader, BuildHeadersTo (buildHeadersTo),                  GetHeaders (getHeaders), HList (..), HasResponseHeader,-                 Headers (..), ResponseHeader (..), addHeader, getHeadersHList,-                 getResponse, lookupResponseHeader, noHeader)+                 Headers (..), ResponseHeader (..), addHeader, addHeader',+                 getHeadersHList, getResponse, lookupResponseHeader, noHeader,+                 noHeader') import           Servant.API.Stream                  (FramingRender (..), FramingUnrender (..), FromSourceIO (..),                  NetstringFraming, NewlineFraming, NoFraming, SourceIO, Stream,

@@ -1,13 +1,12 @@-{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable     #-}-{-# LANGUAGE DeriveFunctor      #-} {-# LANGUAGE DeriveTraversable  #-}-{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE CPP      #-} {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.Alternative ((:<|>)(..)) where -import           Control.Applicative (liftA2)+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif import           Data.Biapplicative                  (Biapplicative (..)) import           Data.Bifoldable@@ -18,8 +17,6 @@                  (Bitraversable (..)) import           Data.Typeable                  (Typeable)-import           Prelude ()-import           Prelude.Compat  -- | Union of two APIs, first takes precedence in case of overlap. --

@@ -1,12 +1,14 @@ {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures     #-}+ {-# LANGUAGE PolyKinds          #-}  module Servant.API.BasicAuth where  import           Data.ByteString                  (ByteString)+import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) import           GHC.TypeLits@@ -24,7 +26,7 @@ -- In Basic Auth, username and password are base64-encoded and transmitted via -- the @Authorization@ header. Handshakes are not required, making it -- relatively efficient.-data BasicAuth (realm :: Symbol) (userData :: *)+data BasicAuth (realm :: Symbol) (userData :: Type)   deriving (Typeable)  -- | A simple datatype to hold data required to decorate a request

@@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.Capture (Capture, Capture', CaptureAll) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) import           GHC.TypeLits@@ -17,7 +19,7 @@ type Capture = Capture' '[] -- todo  -- | 'Capture' which can be modified. For example with 'Description'.-data Capture' (mods :: [*]) (sym :: Symbol) (a :: *)+data Capture' (mods :: [Type]) (sym :: Symbol) (a :: Type)     deriving (Typeable)  -- | Capture all remaining values from the request path under a certain type@@ -27,7 +29,7 @@ -- -- >>>            -- GET /src/* -- >>> type MyAPI = "src" :> CaptureAll "segments" Text :> Get '[JSON] SourceFile-data CaptureAll (sym :: Symbol) (a :: *)+data CaptureAll (sym :: Symbol) (a :: Type)     deriving (Typeable)  -- $setup

@@ -71,7 +71,6 @@  import           Control.Arrow                  (left)-import           Control.Monad.Compat import           Control.DeepSeq                  (NFData) import           Data.Aeson@@ -81,11 +80,11 @@ import qualified Data.ByteString                  as BS import           Data.ByteString.Lazy                  (ByteString, fromStrict, toStrict)+import           Data.Kind+                 (Type) import qualified Data.List.NonEmpty               as NE import           Data.Maybe                  (isJust)-import           Data.String.Conversions-                 (cs) import qualified Data.Text                        as TextS import qualified Data.Text.Encoding               as TextS import qualified Data.Text.Lazy                   as TextL@@ -95,8 +94,6 @@                  (Generic) import qualified GHC.TypeLits                     as TL import qualified Network.HTTP.Media               as M-import           Prelude ()-import           Prelude.Compat import           Web.FormUrlEncoded                  (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) @@ -171,7 +168,7 @@ class Accept ctype => MimeRender ctype a where     mimeRender  :: Proxy ctype -> a -> ByteString -class (AllMime list) => AllCTRender (list :: [*]) a where+class (AllMime list) => AllCTRender (list :: [Type]) a where     -- If the Accept header can be matched, returns (Just) a tuple of the     -- Content-Type and response (serialization of @a@ into the appropriate     -- mimetype).@@ -225,7 +222,7 @@      {-# MINIMAL mimeUnrender | mimeUnrenderWithType #-} -class AllCTUnrender (list :: [*]) a where+class AllCTUnrender (list :: [Type]) a where     canHandleCTypeH         :: Proxy list         -> ByteString  -- Content-Type header@@ -239,12 +236,12 @@  instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where     canHandleCTypeH p ctypeH =-        M.mapContentMedia (allMimeUnrender p) (cs ctypeH)+        M.mapContentMedia (allMimeUnrender p) (toStrict ctypeH)  -------------------------------------------------------------------------- -- * Utils (Internal) -class AllMime (list :: [*]) where+class AllMime (list :: [Type]) where     allMime :: Proxy list -> [M.MediaType]  instance AllMime '[] where@@ -262,7 +259,7 @@ -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeRender ---------------------------------------------------------------------------class (AllMime list) => AllMimeRender (list :: [*]) a where+class (AllMime list) => AllMimeRender (list :: [Type]) a where     allMimeRender :: Proxy list                   -> a                              -- value to serialize                   -> [(M.MediaType, ByteString)]    -- content-types/response pairs@@ -297,12 +294,12 @@ instance {-# OVERLAPPING #-}          ( AllMime (ctyp ': ctyp' ': ctyps)          ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where-    allMimeRender p _ = zip (allMime p) (repeat "")+    allMimeRender p _ = map (, "") (allMime p)  -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender ---------------------------------------------------------------------------class (AllMime list) => AllMimeUnrender (list :: [*]) a where+class (AllMime list) => AllMimeUnrender (list :: [Type]) a where     allMimeUnrender :: Proxy list                     -> [(M.MediaType, ByteString -> Either String a)] @@ -395,7 +392,7 @@  -- | @Right . id@ instance MimeUnrender OctetStream ByteString where-    mimeUnrender _ = Right . id+    mimeUnrender _ = Right  -- | @Right . toStrict@ instance MimeUnrender OctetStream BS.ByteString where

@@ -16,6 +16,8 @@     reflectDescription,     ) where +import           Data.Kind+                 (Type) import           Data.Proxy                  (Proxy (..)) import           Data.Typeable@@ -59,7 +61,7 @@ type FoldDescription mods = FoldDescription' "" mods  -- | Implementation of 'FoldDescription'.-type family FoldDescription' (acc :: Symbol) (mods ::  [*]) :: Symbol where+type family FoldDescription' (acc :: Symbol) (mods ::  [Type]) :: Symbol where     FoldDescription' acc '[]                        = acc     FoldDescription' acc (Description desc ': mods) = FoldDescription' desc mods     FoldDescription' acc (mod     ': mods)          = FoldDescription' acc mods

@@ -2,10 +2,7 @@ {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.Empty(EmptyAPI(..)) where -import           Data.Typeable-                 (Typeable)-import           Prelude ()-import           Prelude.Compat+import           Data.Typeable (Typeable)  -- | An empty API: one which serves nothing. Morally speaking, this should be -- the unit of ':<|>'. Implementors of interpretations of API types should

@@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE KindSignatures     #-}+ {-# LANGUAGE PolyKinds          #-} module Servant.API.Experimental.Auth where 

@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds          #-}-{-# LANGUAGE TypeOperators      #-}+ {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.Fragment (Fragment) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) @@ -14,7 +16,7 @@ -- -- >>> -- /post#TRACKING -- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking-data Fragment (a :: *)+data Fragment (a :: Type)     deriving Typeable  -- $setup

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies     #-} {-# LANGUAGE TypeOperators    #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | Define servant servers from record types. Generics for the win. -- -- The usage is simple, if you only need a collection of routes.  First you@@ -69,6 +70,8 @@ -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. +import           Data.Kind+                 (Type) import           Data.Proxy                  (Proxy (..)) import           GHC.Generics@@ -83,7 +86,7 @@ -- parameter.  For example, 'AsApi' will leave @api@ untouched, while -- @'AsServerT' m@ will produce @'ServerT' api m@. class GenericMode mode where-    type mode :- api :: *+    type mode :- api :: Type  infixl 0 :- 

@@ -6,6 +6,8 @@     Header, Header',     ) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) import           GHC.TypeLits@@ -23,7 +25,7 @@ -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] -data Header' (mods :: [*]) (sym :: Symbol) (a :: *)+data Header' (mods :: [Type]) (sym :: Symbol) (a :: Type)     deriving Typeable  -- $setup

@@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE KindSignatures      #-}+ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Servant.API.Modifiers (     -- * Required / optional argument     Required, Optional,@@ -19,6 +20,8 @@     unfoldRequestArgument,     ) where +import           Data.Kind+                 (Type) import           Data.Proxy                  (Proxy (..)) import           Data.Singletons.Bool@@ -51,7 +54,7 @@ type FoldRequired mods = FoldRequired' 'False mods  -- | Implementation of 'FoldRequired'.-type family FoldRequired' (acc :: Bool) (mods :: [*]) :: Bool where+type family FoldRequired' (acc :: Bool) (mods :: [Type]) :: Bool where     FoldRequired' acc '[]                = acc     FoldRequired' acc (Required ': mods) = FoldRequired' 'True mods     FoldRequired' acc (Optional ': mods) = FoldRequired' 'False mods@@ -72,7 +75,7 @@ type FoldLenient mods = FoldLenient' 'False mods  -- | Implementation of 'FoldLenient'.-type family FoldLenient' (acc :: Bool) (mods ::  [*]) :: Bool where+type family FoldLenient' (acc :: Bool) (mods ::  [Type]) :: Bool where     FoldLenient' acc '[]               = acc     FoldLenient' acc (Lenient ': mods) = FoldLenient' 'True mods     FoldLenient' acc (Strict  ': mods) = FoldLenient' 'False mods

@@ -6,5 +6,7 @@     NamedRoutes   ) where +import Data.Kind (Type)+ -- | Combinator for embedding a record of named routes into a Servant API type.-data NamedRoutes (api :: * -> *)+data NamedRoutes (api :: Type -> Type)

@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds          #-}-{-# LANGUAGE TypeOperators      #-}+ {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) import           GHC.TypeLits@@ -21,7 +23,7 @@ type QueryParam = QueryParam' '[Optional, Strict]  -- | 'QueryParam' which can be 'Required', 'Lenient', or modified otherwise.-data QueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)+data QueryParam' (mods :: [Type]) (sym :: Symbol) (a :: Type)     deriving Typeable  -- | Lookup the values associated to the @sym@ query string parameter@@ -35,7 +37,7 @@ -- -- >>> -- /books?authors[]=<author1>&authors[]=<author2>&... -- >>> type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]-data QueryParams (sym :: Symbol) (a :: *)+data QueryParams (sym :: Symbol) (a :: Type)     deriving Typeable  -- | Lookup a potentially value-less query string parameter

@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_HADDOCK not-home #-}++module Servant.API.QueryString (QueryString, DeepQuery, FromDeepQuery (..), ToDeepQuery (..), generateDeepParam) where++import Data.Bifunctor (Bifunctor (first))+import Data.Kind (Type)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+  ( Typeable,+  )+import GHC.TypeLits+  ( Symbol,+  )+import Web.HttpApiData (FromHttpApiData)+import Web.Internal.HttpApiData (FromHttpApiData (..))++-- | Extract the whole query string from a request. This is useful for query strings+-- containing dynamic parameter names. For query strings with static parameter names,+-- 'QueryParam' is more suited.+--+-- Example:+--+-- >>> -- /books?author=<author name>&year=<book year>+-- >>> type MyApi = "books" :> QueryString :> Get '[JSON] [Book]+data QueryString+  deriving (Typeable)++-- | Extract an deep object from a query string.+--+-- Example:+--+-- >>> -- /books?filter[author][name]=<author name>&filter[year]=<book year>+-- >>> type MyApi = "books" :> DeepQuery "filter" BookQuery :> Get '[JSON] [Book]+data DeepQuery (sym :: Symbol) (a :: Type)+  deriving (Typeable)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Servant.API+-- >>> import Data.Aeson+-- >>> import Data.Text+-- >>> data Book+-- >>> data BookQuery+-- >>> instance ToJSON Book where { toJSON = undefined }++-- | Extract a deep object from (possibly nested) query parameters.+-- a param like @filter[a][b][c]=d@ will be represented as+-- @'(["a", "b", "c"], Just "d")'@. Note that a parameter with no+-- nested field is possible: @filter=a@ will be represented as+-- @'([], Just "a")'@+class FromDeepQuery a where+  fromDeepQuery :: [([Text], Maybe Text)] -> Either String a++instance (FromHttpApiData a) => FromDeepQuery (Map Text a) where+  fromDeepQuery params =+    let parseParam ([k], Just rawV) = (k,) <$> first T.unpack (parseQueryParam rawV)+        parseParam (_, Nothing) = Left "Empty map value"+        parseParam ([], _) = Left "Empty map parameter"+        parseParam (_, Just _) = Left "Nested map values"+     in Map.fromList <$> traverse parseParam params++-- | Generate query parameters from an object, using the deep object syntax.+-- A result of @'(["a", "b", "c"], Just "d")'@ attributed to the @filter@+-- parameter name will result in the following query parameter:+-- @filter[a][b][c]=d@+class ToDeepQuery a where+  toDeepQuery :: a -> [([Text], Maybe Text)]++-- | Turn a nested path into a deep object query param+--+-- >>> generateDeepParam "filter" (["a", "b", "c"], Just "d")+-- ("filter[a][b][c]",Just "d")+generateDeepParam :: Text -> ([Text], Maybe Text) -> (Text, Maybe Text)+generateDeepParam name (keys, value) =+  let makeKeySegment key = "[" <> key <> "]"+   in (name <> foldMap makeKeySegment keys, value)

@@ -6,6 +6,8 @@     ReqBody, ReqBody',     ) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) import           Servant.API.Modifiers@@ -21,7 +23,7 @@ -- | -- -- /Note:/ 'ReqBody'' is always 'Required'.-data ReqBody' (mods :: [*]) (contentTypes :: [*]) (a :: *)+data ReqBody' (mods :: [Type]) (contentTypes :: [Type]) (a :: Type)     deriving (Typeable)  -- $setup

@@ -1,17 +1,5 @@-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveDataTypeable     #-}-{-# LANGUAGE DeriveFunctor          #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-} {-# OPTIONS_HADDOCK not-home        #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}  -- | This module provides facilities for adding headers to a response. --@@ -24,7 +12,9 @@     , ResponseHeader (..)     , AddHeader     , addHeader+    , addHeader'     , noHeader+    , noHeader'     , HasResponseHeader     , lookupResponseHeader     , BuildHeadersTo(buildHeadersTo)@@ -37,8 +27,10 @@ import           Control.DeepSeq                  (NFData (..)) import           Data.ByteString.Char8     as BS-                 (ByteString, init, pack, unlines)+                 (ByteString, pack) import qualified Data.CaseInsensitive      as CI+import           Data.Kind+                 (Type) import qualified Data.List                 as L import           Data.Proxy import           Data.Typeable@@ -49,10 +41,10 @@ import           Web.HttpApiData                  (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) -import           Prelude ()-import           Prelude.Compat import           Servant.API.Header-                 (Header)+                 (Header')+import           Servant.API.Modifiers+                 (Optional, Strict) import           Servant.API.UVerb.Union import qualified Data.SOP.BasicFunctors as SOP import qualified Data.SOP.NS as SOP@@ -81,19 +73,19 @@  data HList a where     HNil  :: HList '[]-    HCons :: ResponseHeader h x -> HList xs -> HList (Header h x ': xs)+    HCons :: ResponseHeader h x -> HList xs -> HList (Header' mods h x ': xs)  class NFDataHList xs where rnfHList :: HList xs -> () instance NFDataHList '[] where rnfHList HNil = ()-instance (y ~ Header h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where+instance (y ~ Header' mods h x, NFData x, NFDataHList xs) => NFDataHList (y ': xs) where     rnfHList (HCons h xs) = rnf h `seq` rnfHList xs  instance NFDataHList xs => NFData (HList xs) where     rnf = rnfHList -type family HeaderValMap (f :: * -> *) (xs :: [*]) where+type family HeaderValMap (f :: Type -> Type) (xs :: [Type]) where     HeaderValMap f '[]                = '[]-    HeaderValMap f (Header h x ': xs) = Header h (f x) ': HeaderValMap f xs+    HeaderValMap f (Header' mods h x ': xs) = Header' mods h (f x) ': HeaderValMap f xs   class BuildHeadersTo hs where@@ -105,7 +97,7 @@ -- The current implementation does not manipulate HTTP header field lines in any way, -- like merging field lines with the same field name in a single line. instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )-         => BuildHeadersTo (Header h v ': xs) where+         => BuildHeadersTo (Header' mods h v ': xs) where     buildHeadersTo headers = case L.find wantedHeader headers of       Nothing -> MissingHeader `HCons` buildHeadersTo headers       Just header@(_, val) -> case parseHeader val of@@ -130,7 +122,7 @@     getHeadersFromHList _ = []  instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)-    => GetHeadersFromHList (Header h x ': xs)+    => GetHeadersFromHList (Header' mods h x ': xs)   where     getHeadersFromHList hdrs = case hdrs of         Header val `HCons` rest          -> (headerName , toHeader val) : getHeadersFromHList rest@@ -151,42 +143,42 @@     getHeaders' _ = []  instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)-    => GetHeaders' (Header h v ': rest)+    => GetHeaders' (Header' mods h v ': rest)   where     getHeaders' hs = getHeadersFromHList $ getHeadersHList hs  -- * Adding headers  -- We need all these fundeps to save type inference-class AddHeader h v orig new-    | h v orig -> new, new -> h, new -> v, new -> orig where+class AddHeader (mods :: [Type]) h v orig new+    | mods h v orig -> new, new -> mods, new -> h, new -> v, new -> orig where   addOptionalHeader :: ResponseHeader h v -> orig -> new  -- ^ N.B.: The same header can't be added multiple times  -- In this instance, we add a Header on top of something that is already decorated with some headers instance {-# OVERLAPPING #-} ( KnownSymbol h, ToHttpApiData v )-         => AddHeader h v (Headers (fst ': rest)  a) (Headers (Header h v  ': fst ': rest) a) where+         => AddHeader mods h v (Headers (fst ': rest)  a) (Headers (Header' mods h v  ': fst ': rest) a) where     addOptionalHeader hdr (Headers resp heads) = Headers resp (HCons hdr heads)  -- In this instance, 'a' parameter is decorated with a Header.-instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header h v] a)-         => AddHeader h v a new where+instance {-# OVERLAPPABLE #-} ( KnownSymbol h, ToHttpApiData v , new ~ Headers '[Header' mods h v] a)+         => AddHeader mods h v a new where     addOptionalHeader hdr resp = Headers resp (HCons hdr HNil)  -- Instances to decorate all responses in a 'Union' with headers. The functional -- dependencies force us to consider singleton lists as the base case in the -- recursion (it is impossible to determine h and v otherwise from old / new -- responses if the list is empty).-instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where+instance (AddHeader mods h v old new) => AddHeader mods h v (Union '[old]) (Union '[new]) where   addOptionalHeader hdr resp =-    SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp+    SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ resp  instance-  ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest)+  ( AddHeader mods h v old new, AddHeader mods h v (Union oldrest) (Union newrest)   -- This ensures that the remainder of the response list is _not_ empty   -- It is necessary to prevent the two instances for union types from   -- overlapping.   , oldrest ~ (a ': as), newrest ~ (b ': bs))-  => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where+  => AddHeader mods h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where   addOptionalHeader hdr resp = case resp of     SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead     SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers@@ -211,21 +203,29 @@ -- Note that while in your handlers type annotations are not required, since -- the type can be inferred from the API type, in other cases you may find -- yourself needing to add annotations.-addHeader :: AddHeader h v orig new => v -> orig -> new+addHeader :: AddHeader '[Optional, Strict] h v orig new => v -> orig -> new addHeader = addOptionalHeader . Header +-- | Same as 'addHeader' but works with `Header'`, so it's possible to use any @mods@.+addHeader' :: AddHeader mods h v orig new => v -> orig -> new+addHeader' = addOptionalHeader . Header+ -- | Deliberately do not add a header to a value. -- -- >>> let example1 = noHeader "hi" :: Headers '[Header "someheader" Int] String -- >>> getHeaders example1 -- []-noHeader :: AddHeader h v orig new => orig -> new+noHeader :: AddHeader '[Optional, Strict] h v orig new => orig -> new noHeader = addOptionalHeader MissingHeader +-- | Same as 'noHeader' but works with `Header'`, so it's possible to use any @mods@.+noHeader' :: AddHeader mods h v orig new => orig -> new+noHeader' = addOptionalHeader MissingHeader+ class HasResponseHeader h a headers where   hlistLookupHeader :: HList headers -> ResponseHeader h a -instance {-# OVERLAPPING #-} HasResponseHeader h a (Header h a ': rest) where+instance {-# OVERLAPPING #-} HasResponseHeader h a (Header' mods h a ': rest) where   hlistLookupHeader (HCons ha _) = ha  instance {-# OVERLAPPABLE #-} (HasResponseHeader h a rest) => HasResponseHeader h a (first ': rest) where

@@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}++ {-# LANGUAGE OverloadedStrings      #-} {-# LANGUAGE PolyKinds              #-} {-# LANGUAGE RankNTypes             #-}@@ -45,6 +45,8 @@ import qualified Data.ByteString                  as BS import qualified Data.ByteString.Lazy             as LBS import qualified Data.ByteString.Lazy.Char8       as LBS8+import           Data.Kind+                 (Type) import           Data.List.NonEmpty                  (NonEmpty (..)) import           Data.Proxy@@ -63,7 +65,7 @@ -- given @Content-Type@, delimited by a @framing@ strategy. -- Type synonyms are provided for standard methods. ---data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)+data Stream (method :: k1) (status :: Nat) (framing :: Type) (contentType :: Type) (a :: Type)   deriving (Typeable, Generic)  type StreamGet  = Stream 'GET 200@@ -72,7 +74,7 @@ -- | A stream request body. type StreamBody = StreamBody' '[] -data StreamBody' (mods :: [*]) (framing :: *) (contentType :: *) (a :: *)+data StreamBody' (mods :: [Type]) (framing :: Type) (contentType :: Type) (a :: Type)   deriving (Typeable, Generic)  -------------------------------------------------------------------------------

@@ -4,6 +4,8 @@ {-# OPTIONS_HADDOCK not-home    #-} module Servant.API.Sub ((:>)) where +import           Data.Kind+                 (Type) import           Data.Typeable                  (Typeable) @@ -15,7 +17,7 @@ -- >>> -- GET /hello/world -- >>> -- returning a JSON encoded World value -- >>> type MyApi = "hello" :> "world" :> Get '[JSON] World-data (path :: k) :> (a :: *)+data (path :: k) :> (a :: Type)     deriving (Typeable) infixr 4 :> 

@@ -16,7 +16,7 @@   ErrorIfNoGeneric, ) where -import Data.Kind+import Data.Kind (Type, Constraint) import GHC.Generics (Generic(..)) import GHC.TypeLits 

@@ -2,7 +2,7 @@ {-# LANGUAGE ConstraintKinds          #-} {-# LANGUAGE DataKinds                #-} {-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE KindSignatures           #-}+ {-# LANGUAGE MultiParamTypeClasses    #-} {-# LANGUAGE PolyKinds                #-} {-# LANGUAGE ScopedTypeVariables      #-}@@ -47,23 +47,29 @@     And,     -- ** Fragment     FragmentUnique,-    AtLeastOneFragment+    AtMostOneFragment     ) where   import           GHC.Exts                  (Constraint)+import           Data.Kind+                 (Type) import           Servant.API.Alternative                  (type (:<|>)) import           Servant.API.Capture                  (Capture, CaptureAll) import           Servant.API.Fragment import           Servant.API.Header-                 (Header)+                 (Header, Header') import           Servant.API.QueryParam                  (QueryFlag, QueryParam, QueryParams) import           Servant.API.ReqBody                  (ReqBody)+import           Servant.API.NamedRoutes+                 (NamedRoutes)+import           Servant.API.Generic+                 (ToServantApi) import           Servant.API.Sub                  (type (:>)) import           Servant.API.Verbs@@ -130,6 +136,7 @@   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 (Header' mods 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@@ -142,6 +149,7 @@   IsElem (Verb m s ct typ) (Verb m s ct' typ)                                           = IsSubList ct ct'   IsElem e e                              = ()+  IsElem e (NamedRoutes rs)               = IsElem e (ToServantApi rs)   IsElem e a                              = IsElem' e a  -- | Check whether @sub@ is a sub-API of @api@.@@ -176,10 +184,11 @@ -- ... -- ... Could not ... -- ...-type family IsIn (endpoint :: *) (api :: *) :: Constraint where+type family IsIn (endpoint :: Type) (api :: Type) :: Constraint where   IsIn e (sa :<|> sb)                = Or (IsIn e sa) (IsIn e sb)   IsIn (e :> sa) (e :> sb)           = IsIn sa sb   IsIn e e                           = ()+  IsIn e (NamedRoutes record)        = IsIn e (ToServantApi record)  -- | Check whether @sub@ is a sub API of @api@. --@@ -235,14 +244,14 @@  -- ** Logic --- | If either a or b produce an empty constraint, produce an empty constraint.+-- | 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.+-- | If both 'a' or 'b' produce an empty constraint, produce an empty constraint. type family And (a :: Constraint) (b :: Constraint) :: Constraint where   And () ()     = () @@ -254,21 +263,21 @@  -- ** Fragment -class FragmentUnique api => AtLeastOneFragment api---- | If fragment appeared in API endpoint twice, compile-time error would be raised.+-- | If there is more than one fragment in an API endpoint,+-- a compile-time error is raised. ----- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent--- >>> instance AtLeastOneFragment FailAPI+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent+-- >>> instance AtMostOneFragment FailAPI -- ... -- ...Only one Fragment allowed per endpoint in api... -- ...--- ...In the instance declaration for...-instance AtLeastOneFragment (Verb m s ct typ)+class FragmentUnique api => AtMostOneFragment api -instance AtLeastOneFragment (UVerb m cts as)+instance AtMostOneFragment (Verb m s ct typ) -instance AtLeastOneFragment (Fragment a)+instance AtMostOneFragment (UVerb m cts as)++instance AtMostOneFragment (Fragment a)  type family FragmentUnique api :: Constraint where   FragmentUnique (sa :<|> sb)       = And (FragmentUnique sa) (FragmentUnique sb)

@@ -1,7 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -10,8 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | An alternative to 'Verb' for end-points that respond with a resource value of any of an -- open union of types, and specific status codes for each type in this union.  (`UVerb` is -- short for `UnionVerb`)@@ -33,6 +33,7 @@   ) where +import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits (Nat) import Network.HTTP.Types (Status, StdMethod)@@ -41,8 +42,8 @@ import Servant.API.ResponseHeaders (Headers) import Servant.API.UVerb.Union -class KnownStatus (StatusOf a) => HasStatus (a :: *) where-  type StatusOf (a :: *) :: Nat+class KnownStatus (StatusOf a) => HasStatus (a :: Type) where+  type StatusOf (a :: Type) :: Nat  statusOf :: forall a proxy. HasStatus a => proxy a -> Status statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))@@ -53,8 +54,8 @@ instance HasStatus NoContent where   type StatusOf NoContent = 204 -class HasStatuses (as :: [*]) where-  type Statuses (as :: [*]) :: [Nat]+class HasStatuses (as :: [Type]) where+  type Statuses (as :: [Type]) :: [Nat]   statuses :: Proxy as -> [Status]  instance HasStatuses '[] where@@ -100,7 +101,7 @@ -- -- Backwards compatibility is tricky, though: this type alias would mean people would have to -- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.-data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])+data UVerb (method :: StdMethod) (contentTypes :: [Type]) (as :: [Type])  instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where   mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a

@@ -1,9 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}+ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}+ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}@@ -59,6 +59,7 @@ ) where +import Data.Kind (Type) import Data.Proxy (Proxy) import Data.SOP.BasicFunctors (I, unI) import Data.SOP.Constraint@@ -75,7 +76,7 @@ -- -- See also: 'matchUnion'. foldMapUnion ::-  forall (c :: * -> Constraint) (a :: *) (as :: [*]).+  forall (c :: Type -> Constraint) (a :: Type) (as :: [Type]).   All c as =>   Proxy c ->   (forall x. c x => x -> a) ->@@ -88,7 +89,7 @@ -- otherwise. -- -- See also: 'foldMapUnion'.-matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a+matchUnion :: forall (a :: Type) (as :: [Type]). (IsMember a as) => Union as -> Maybe a matchUnion = fmap unI . eject  -- * Stuff stolen from 'Data.WorldPeace" but for generics-sop

@@ -1,13 +1,15 @@ {-# LANGUAGE DataKinds          #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE KindSignatures     #-}+ {-# LANGUAGE PolyKinds          #-} module Servant.API.Verbs   ( module Servant.API.Verbs   , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)   ) where +import           Data.Kind+                 (Type) import           Data.Proxy                  (Proxy) import           Data.Typeable@@ -26,7 +28,7 @@ -- provided, but you are free to define your own: -- -- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a-data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *)+data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type)   deriving (Typeable, Generic)  -- | @NoContentVerb@ is a specific type to represent 'NoContent' responses.

@@ -4,6 +4,8 @@ module Servant.API.WithNamedContext where  import           GHC.TypeLits+import           Data.Kind+                 (Type)  -- | 'WithNamedContext' names a specific tagged context to use for the -- combinators in the API. (See also in @servant-server@,@@ -18,4 +20,4 @@ -- 'Context's are only relevant for @servant-server@. -- -- For more information, see the tutorial.-data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi+data WithNamedContext (name :: Symbol) (subContext :: [Type]) subApi

@@ -1,26 +1,13 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE InstanceSigs           #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE QuantifiedConstraints    #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# OPTIONS_HADDOCK not-home        #-}+{-# OPTIONS_GHC -Wno-missing-methods -Wno-redundant-constraints #-}  -- | Type safe generation of internal links. -- -- Given an API with a few endpoints: ----- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators -XPolyKinds -- >>> import Servant.API -- >>> import Servant.Links -- >>> import Web.HttpApiData (toUrlPiece)@@ -130,7 +117,9 @@   , linkFragment ) where -import           Data.List+import           Data.Kind+                 (Type)+import qualified Data.List as List import           Data.Constraint import           Data.Proxy                  (Proxy (..))@@ -144,8 +133,6 @@                  (KnownSymbol, TypeError, symbolVal) import           Network.URI                  (URI (..), escapeURIString, isUnreserved)-import           Prelude ()-import           Prelude.Compat  import           Servant.API.Alternative                  ((:<|>) ((:<|>)))@@ -196,8 +183,6 @@ import           Servant.API.WithResource                  (WithResource) import           Web.HttpApiData-import           Data.Kind-                 (Type)  -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any@@ -298,14 +283,14 @@ linkURI' addBrackets (Link segments q_params mfragment) =     URI mempty  -- No scheme (relative)         Nothing -- Or authority (relative)-        (intercalate "/" $ map getEscaped segments)+        (List.intercalate "/" $ map getEscaped segments)         (makeQueries q_params)         (makeFragment mfragment)   where     makeQueries :: [Param] -> String     makeQueries [] = ""     makeQueries xs =-        "?" <> intercalate "&" (fmap makeQuery xs)+        "?" <> List.intercalate "&" (fmap makeQuery xs)      makeQuery :: Param -> String     makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)@@ -358,7 +343,7 @@ -- Note: nested APIs don't work well with this approach -- -- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link--- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: Type -- = Char -> (Int -> Link) :<|> (Double -> Link) allLinks     :: forall api. HasLink api@@ -394,10 +379,11 @@ -- -- @since 0.14.1 fieldLink-    :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint+    :: ( IsElem endpoint (ToServantApi routes)+       , HasLink endpoint        , GenericServant routes AsApi        )-    => (routes AsApi -> endpoint)+    =>(routes AsApi -> endpoint)     -> MkLink endpoint Link fieldLink = fieldLink' id @@ -406,10 +392,11 @@ -- @since 0.14.1 fieldLink'     :: forall routes endpoint a.-       ( IsElem endpoint (ToServantApi routes), HasLink endpoint+       ( IsElem endpoint (ToServantApi routes)+       , HasLink endpoint        , GenericServant routes AsApi        )-    => (Link -> a)+    =>(Link -> a)     -> (routes AsApi -> endpoint)     -> MkLink endpoint a fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)@@ -417,7 +404,7 @@ -- | A type that specifies that an API record contains a set of links. -- -- @since 0.14.1-data AsLink (a :: *)+data AsLink (a :: Type) instance GenericMode (AsLink a) where     type (AsLink a) :- api = MkLink api a @@ -453,7 +440,7 @@  -- | Construct a toLink for an endpoint. class HasLink endpoint where-    type MkLink endpoint (a :: *)+    type MkLink endpoint (a :: Type)     toLink         :: (Link -> a)         -> Proxy endpoint -- ^ The API endpoint you would like to point to@@ -488,7 +475,7 @@     type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a     toLink toA _ l =         toLink toA (Proxy :: Proxy sub) .-            foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l+            List.foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l       where         k = symbolVal (Proxy :: Proxy sym) @@ -530,9 +517,9 @@   where     type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a     toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $-        foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs+        List.foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs -instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where+instance HasLink sub => HasLink (Header' mods sym (a :: Type) :> sub) where     type MkLink (Header' mods sym a :> sub) r = MkLink sub r     toLink = simpleToLink (Proxy :: Proxy sub) @@ -608,7 +595,7 @@   , GenericServant routes (AsLink a)   ) -class GLink (routes :: * -> *) (a :: *) where+class GLink (routes :: Type -> Type) (a :: Type) where   gLinkProof :: Dict (GLinkConstraints routes a)  instance GLinkConstraints routes a => GLink routes a where@@ -661,19 +648,19 @@ -- >>> import Data.Text (Text)  -- Erroring instance for 'HasLink' when a combinator is not fully applied-instance TypeError (PartialApplication +instance TypeError (PartialApplication #if __GLASGOW_HASKELL__ >= 904-                    @(Type -> Constraint) +                    @(Type -> Constraint) #endif                     HasLink arr) => HasLink ((arr :: a -> b) :> sub)   where-    type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)+    type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: Type -> Constraint) arr)     toLink = error "unreachable"  -- Erroring instances for 'HasLink' for unknown API combinators-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub +instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub #if __GLASGOW_HASKELL__ >= 904-                                         @(Type -> Constraint) +                                         @(Type -> Constraint) #endif                                          HasLink ty) => HasLink (ty :> sub) 

@@ -1,8 +1,4 @@ {-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-} module Servant.Types.SourceT where  import           Control.Monad.Except@@ -17,14 +13,13 @@                  (Show1 (..), showsBinaryWith, showsPrec1, showsUnaryWith) import           Data.Functor.Identity                  (Identity (..))-import           Prelude ()-import           Prelude.Compat             hiding-                 (readFile)+import           Prelude hiding (readFile) import           System.IO                  (Handle, IOMode (..), withFile) import qualified Test.QuickCheck            as QC  -- $setup+-- >>> :set -XNoOverloadedStrings -- >>> import Data.String (fromString) -- >>> import Control.Monad.Except (runExcept) -- >>> import Data.Foldable (toList)@@ -88,7 +83,7 @@ -- fromStepT (Effect (Just (Yield 1 (Yield 2 (Yield 3 Stop))))) instance MFunctor SourceT where     hoist f (SourceT m) = SourceT $ \k -> k $-        Effect $ f $ fmap (hoist f) $ m return+        Effect $ f $ fmap (hoist f) $ m pure  -- | >>> source "xy" <> source "z" :: SourceT Identity Char -- fromStepT (Effect (Identity (Yield 'x' (Yield 'y' (Yield 'z' Stop)))))@@ -196,7 +191,7 @@               | otherwise = QC.frequency                   [ (1, pure Stop)                   , (1, Skip <$> arb')-                  , (1, Effect . return <$> arb')+                  , (1, Effect . pure <$> arb')                   , (8, Yield <$> QC.arbitrary <*> arb')                   ]           where@@ -234,7 +229,7 @@ runSourceT (SourceT m) = ExceptT (m (runExceptT . runStepT))  runStepT :: Monad m => StepT m a -> ExceptT String m [a]-runStepT Stop        = return []+runStepT Stop        = pure [] runStepT (Error err) = throwError err runStepT (Skip s)    = runStepT s runStepT (Yield x s) = fmap (x :) (runStepT s)@@ -245,9 +240,9 @@ -- Identity (Just ('f',Yield 'o' (Yield 'o' Stop))) -- uncons :: Monad m => StepT m a -> m (Maybe (a, StepT m a))-uncons Stop        = return Nothing+uncons Stop        = pure Nothing uncons (Skip s)    = uncons s-uncons (Yield x s) = return (Just (x, s))+uncons (Yield x s) = pure (Just (x, s)) uncons (Effect ms) = ms >>= uncons uncons (Error _) = -}@@ -297,7 +292,7 @@     -> StepT m a     -> m () foreachStep f g = go where-    go Stop        = return ()+    go Stop        = pure ()     go (Skip s)    = go s     go (Yield x s) = g x >> go s     go (Error err) = f err@@ -326,8 +321,8 @@ -- | Read file. -- -- >>> foreach fail BS.putStr (readFile "servant.cabal")--- cabal-version:       2.2--- name:                servant+-- cabal-version:      3.0+-- name:               servant -- ... -- readFile :: FilePath -> SourceT IO BS.ByteString

@@ -8,13 +8,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where -import           Prelude ()-import           Prelude.Compat--import           Data.Aeson-                 (FromJSON, ToJSON (..), Value, decode, encode, object, (.=), eitherDecode)-import           Data.ByteString.Char8-                 (ByteString, append, pack)+import           Data.Aeson (FromJSON, ToJSON (..), Value, decode, encode, object, (.=), eitherDecode)+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy                             as BSL import qualified Data.ByteString.Lazy.Char8                       as BSL8 import           Data.Either@@ -28,8 +24,6 @@ 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@@ -37,6 +31,7 @@                  (evaluate) import           GHC.Generics import           Test.Hspec+import           Network.HTTP.Media () -- for CPP import           Test.QuickCheck import           "quickcheck-instances" Test.QuickCheck.Instances () import           Text.Read@@ -84,7 +79,7 @@         let p = Proxy :: Proxy '[JSON]          it "does not render any content" $-          allMimeRender p NoContent `shouldSatisfy` (all (BSL8.null . snd))+          allMimeRender p NoContent `shouldSatisfy` all (BSL8.null . snd)          it "evaluates the NoContent value" $           evaluate (allMimeRender p (undefined :: NoContent)) `shouldThrow` anyErrorCall@@ -161,8 +156,7 @@ #endif             let acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $                                 addToAccept (Proxy :: Proxy JSON)        b $-                                addToAccept (Proxy :: Proxy PlainText )  c $-                                ""+                                addToAccept (Proxy :: Proxy PlainText )  c ""             let val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText])                                             (acceptH a b c) (i :: Int)             property $ \a b c i ->@@ -244,13 +238,13 @@     arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]  instance MimeRender OctetStream Int where-    mimeRender _ = cs . show+    mimeRender _ = BSL8.pack . show  instance MimeRender PlainText Int where-    mimeRender _ = cs . show+    mimeRender _ = BSL8.pack . show  instance MimeRender PlainText ByteString where-    mimeRender _ = cs+    mimeRender _ = BSL.fromStrict  instance ToJSON ByteString where     toJSON x = object [ "val" .= x ]@@ -265,7 +259,7 @@     contentTypes _ = "text/plain" NE.:| [ "application/json" ]  instance MimeRender JSONorText Int  where-    mimeRender _ = cs . show+    mimeRender _ = BSL8.pack . show  instance MimeUnrender JSONorText Int where     mimeUnrender _ = maybe (Left "") Right . readMaybe . BSL8.unpack@@ -277,6 +271,6 @@  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)+    where new = BS8.pack (show $ contentType p) <> "; q=" <> BS8.pack (show f)           cont "" = new-          cont old = old `append` ", " `append` new+          cont old = old <> ", " <> new

@@ -7,7 +7,11 @@ import           Test.Hspec  import           Servant.API.ContentTypes+import           Servant.API.Description+                 (Description) import           Servant.API.Header+import           Servant.API.Modifiers+                 (Optional, Strict) import           Servant.API.ResponseHeaders import           Servant.API.UVerb @@ -26,6 +30,10 @@     it "adds headers to the front of the list" $ do       let val = addHeader 10 $ addHeader "b" 5 :: Headers '[Header "first" Int, Header "second" String] Int       getHeaders val `shouldBe` [("first", "10"), ("second", "b")]++    it "adds a header with description to a value" $ do+      let val = addHeader' "hi" 5 :: Headers '[Header' '[Description "desc", Optional, Strict] "test" String] Int+      getHeaders val `shouldBe` [("test", "hi")]    describe "noHeader" $ do 

@@ -1,10 +1,13 @@ {-# LANGUAGE ConstraintKinds     #-} {-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE PolyKinds           #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-} module Servant.LinksSpec where +import           GHC.Generics+                 (Generic) import           Data.Proxy                  (Proxy (..)) import           Data.String@@ -44,17 +47,51 @@        "all" :> CaptureAll "names" String :> Get '[JSON] NoContent   :<|> "get" :> Get '[JSON] NoContent - apiLink :: (IsElem endpoint TestApi, HasLink endpoint)          => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) ++newtype QuuxRoutes mode = QuuxRoutes+  { corge :: mode :- "corge" :> Post '[PlainText] NoContent+  } deriving Generic++newtype WaldoRoutes mode = WaldoRoutes+  { waldo :: mode :- "waldo" :> Get '[JSON] NoContent+  } deriving Generic++data FooRoutes mode = FooRoutes+  { baz :: mode :- "baz" :> Get '[JSON] NoContent+  , qux :: mode :- "qux" :> NamedRoutes QuuxRoutes+  , quux :: mode :- "quux" :> QueryParam "grault" String :> Get '[JSON] NoContent+  , garply :: mode :- "garply" :> Capture "garply" String+           :> Capture "garplyNum" Int :> NamedRoutes WaldoRoutes+  } deriving Generic++data BaseRoutes mode = BaseRoutes+  { foo :: mode :- "foo" :> NamedRoutes FooRoutes+  , bar :: mode :- "bar" :> Get '[JSON] NoContent+  } deriving Generic++recordApiLink+  :: (IsElem endpoint (NamedRoutes BaseRoutes), HasLink endpoint)+  => Proxy endpoint -> MkLink endpoint Link+recordApiLink = safeLink (Proxy :: Proxy (NamedRoutes BaseRoutes))+ -- | Convert a link to a URI and ensure that this maps to the given string -- given string shouldBeLink :: Link -> String -> Expectation shouldBeLink link expected =     toUrlPiece link `shouldBe` fromString expected +(//) :: a -> (a -> b) -> b+x // f = f x+infixl 1 //++(/:) :: (a -> b -> c) -> b -> a -> c+(/:) = flip+infixl 2 /:+ spec :: Spec spec = describe "Servant.Links" $ do     it "generates correct links for capture query params" $ do@@ -105,6 +142,33 @@     it "can generate all links for ComprehensiveAPIWithoutRaw" $ do         let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw         firstLink `shouldBeLink` ""++    it "Generate links from record fields accessors" $ do+      fieldLink bar `shouldBeLink` "bar"+      (fieldLink foo // baz)  `shouldBeLink` "foo/baz"+      (fieldLink foo // qux // corge) `shouldBeLink` "foo/qux/corge"+      (fieldLink foo // quux /: Nothing) `shouldBeLink` "foo/quux"+      (fieldLink foo // quux /: Just "floop") `shouldBeLink` "foo/quux?grault=floop"+      (fieldLink foo // garply /: "captureme" /: 42 // waldo)+        `shouldBeLink` "foo/garply/captureme/42/waldo"++    it "Check links from record fields" $ do+      let sub1 = Proxy :: Proxy ("bar" :> Get '[JSON] NoContent)+      recordApiLink sub1 `shouldBeLink` "bar"++      let sub2 = Proxy :: Proxy ("foo" :> "baz" :> Get '[JSON] NoContent)+      recordApiLink sub2 `shouldBeLink` "foo/baz"++      let sub3 = Proxy :: Proxy ("foo" :> "quux" :> QueryParam "grault" String+                                       :> Get '[JSON] NoContent)+      recordApiLink sub3 (Just "floop") `shouldBeLink` "foo/quux?grault=floop"++      let sub4 :: Proxy ("foo" :> "garply" :> Capture "garplyText" String+                       :> Capture "garplyInt" Int :> "waldo"+                       :> Get '[JSON] NoContent)+          sub4 = Proxy+      recordApiLink sub4 "captureme" 42+        `shouldBeLink` "foo/garply/captureme/42/waldo"  -- The doctests below aren't run on CI, setting that up is tricky. -- They are run by makefile rule, however.