servant-util (empty) → 0.1.0

raw patch · 54 files changed

+4990/−0 lines, 54 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, containers, data-default, fmt, hspec, hspec-expectations, http-client, http-types, insert-ordered-containers, lens, megaparsec, mtl, pretty-terminal, reflection, regex-posix, safe-exceptions, servant, servant-client, servant-client-core, servant-server, servant-swagger, servant-swagger-ui, servant-swagger-ui-core, servant-util, swagger2, text, text-format, time, universum, wai, wai-extra, warp

Files

• CHANGES.md +8/−0
• README.md +364/−0
• examples/Books.hs +80/−0
• examples/Main.hs +6/−0
• servant-util.cabal +206/−0
• src/Servant/Util.hs +9/−0
• src/Servant/Util/Combinators.hs +1/−0
• src/Servant/Util/Combinators/ErrorResponses.hs +152/−0
• src/Servant/Util/Combinators/Filtering.hs +35/−0
• src/Servant/Util/Combinators/Filtering/Backend.hs +196/−0
• src/Servant/Util/Combinators/Filtering/Base.hs +205/−0
• src/Servant/Util/Combinators/Filtering/Client.hs +57/−0
• src/Servant/Util/Combinators/Filtering/Construction.hs +193/−0
• src/Servant/Util/Combinators/Filtering/Filters.hs +2/−0
• src/Servant/Util/Combinators/Filtering/Filters/General.hs +112/−0
• src/Servant/Util/Combinators/Filtering/Filters/Like.hs +122/−0
• src/Servant/Util/Combinators/Filtering/Getters.hs +43/−0
• src/Servant/Util/Combinators/Filtering/Logging.hs +75/−0
• src/Servant/Util/Combinators/Filtering/Server.hs +141/−0
• src/Servant/Util/Combinators/Filtering/Support.hs +50/−0
• src/Servant/Util/Combinators/Filtering/Swagger.hs +111/−0
• src/Servant/Util/Combinators/Logging.hs +423/−0
• src/Servant/Util/Combinators/Pagination.hs +184/−0
• src/Servant/Util/Combinators/Sorting.hs +32/−0
• src/Servant/Util/Combinators/Sorting/Arbitrary.hs +25/−0
• src/Servant/Util/Combinators/Sorting/Backend.hs +102/−0
• src/Servant/Util/Combinators/Sorting/Base.hs +223/−0
• src/Servant/Util/Combinators/Sorting/Client.hs +30/−0
• src/Servant/Util/Combinators/Sorting/Construction.hs +90/−0
• src/Servant/Util/Combinators/Sorting/Logging.hs +31/−0
• src/Servant/Util/Combinators/Sorting/Server.hs +86/−0
• src/Servant/Util/Combinators/Sorting/Swagger.hs +62/−0
• src/Servant/Util/Combinators/Tag.hs +127/−0
• src/Servant/Util/Common.hs +1/−0
• src/Servant/Util/Common/Common.hs +85/−0
• src/Servant/Util/Common/HList.hs +64/−0
• src/Servant/Util/Common/PolyKinds.hs +131/−0
• src/Servant/Util/Dummy.hs +2/−0
• src/Servant/Util/Dummy/Filtering.hs +105/−0
• src/Servant/Util/Dummy/Pagination.hs +13/−0
• src/Servant/Util/Dummy/Sorting.hs +77/−0
• src/Servant/Util/Error.hs +24/−0
• src/Servant/Util/Internal/Util.hs +45/−0
• src/Servant/Util/Stats.hs +55/−0
• src/Servant/Util/Swagger.hs +156/−0
• src/Servant/Util/Util.hs +9/−0
• tests/Main.hs +7/−0
• tests/Spec.hs +1/−0
• tests/Test/Servant/Filtering/GeneralSpec.hs +38/−0
• tests/Test/Servant/Filtering/ImplSpec.hs +189/−0
• tests/Test/Servant/Filtering/LikeSpec.hs +22/−0
• tests/Test/Servant/Helpers.hs +69/−0
• tests/Test/Servant/Pagination/ImplSpec.hs +107/−0
• tests/Test/Servant/Sorting/ImplSpec.hs +207/−0

@@ -0,0 +1,8 @@+Unreleased+=====++* Added logging.+* Added sorting.+* Added pagination.+* Added swagger tags.+* Added swagger error responses.

@@ -0,0 +1,364 @@+# Servant-util++This package contains the core primitives which directly participate in API and some common utilities.++## Build Instructions++Run `stack build servant-util` to build everything.++## Usage++For the following examples, we consider a simple server with two endpoints.++```haskell++import Universum++import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.TH (defaultOptions, deriveJSON)+import qualified Network.Wai.Handler.Warp as Warp+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import Servant ((:<|>) (..), (:>), FromHttpApiData, Get, JSON, PostCreated, QueryParam, ReqBody,+                Server, serve)+import Servant.Util ()++newtype Isbn = Isbn Word64+    deriving (Eq, Show, ToJSON, FromJSON)++data Book = Book+    { isbn     :: Isbn+    , bookName :: Text+    , author   :: Text+    }++deriveJSON defaultOptions 'Book++newtype Password = Password Text+    deriving (FromHttpApiData)++type GetBooks+    = Get '[JSON] [Book]++type AddBook+    =  QueryParam "password" Password+    :> ReqBody '[JSON] Book+    :> PostCreated '[JSON] Isbn++type BooksAPI = "books" :> (+    GetBooks :<|>+    AddBook+  )++booksHandlers :: Server BooksAPI+booksHandlers =+    (return [])+    :<|>+    (\_ book -> return (isbn book))++warpSettings :: Warp.Settings+warpSettings = Warp.defaultSettings+    & Warp.setHost "127.0.0.1"+    & Warp.setPort 8090++serveBooksServer :: IO ()+serveBooksServer =+    Warp.runSettings warpSettings $+    serve (Proxy @BooksAPI) booksHandlers++```++### Sorting++When an endpoint is extended with a `SortingParams` combinator, it starts to accept a sorting+specification in `sortBy` query parameter. This way, the user can supply a sequence of fields+from the set of allowed fields. They will be applied lexicographically in the specified order.++For example, `GetBooks` from the example above can be extended as++```haskell++type GetBooks+    :> SortingParams+         ["isbn" ?: Isbn, "name" ?: Text, "author" ?: Text]+        '["isbn" ?: 'Asc Isbn]+    =  Get '[JSON] [Book]++```++The first list required by `SortingParams` combinator should consist of fields that+are allowed to participate in sorting.+The first argument of `?:` operator stands for a field name from front-end's point+of view; the second argument corresponds to the field type and used primarily to avoid+mistakes in the implementation.++(Soon, it will also be used to distinguish between nullable and mandatory fields.)++The second list required by `SortingParams` stands for the base sorting that will+always be applied last disregard the user's input. It allows for more+deterministic results and is, in fact, essential when paired with pagination.++Examples of valid requests to this server (using [httpie](https://httpie.org/)):+* `http :8090/books sortBy=='asc(name)'` — sort alphabetically by `name` (for equal names — by `isbn`);+* `http :8090/books sortBy=='asc(name),desc(author)'` — sort alphabetically by `name`, for equal names — by `author` in reversed order (and for entries with the same name and author - by `isbn`).+* `http :8090/books sortBy==+name,-author'` — same as above.++The server handler will be supplied with `SortingSpec` argument, use neighbor `servant-util-*`+packages for applying this specification to your backend.++You can also use methods from [`Servant.Util.Dummy`](src/Servant/Util/Dummy.hs) for a trivial in-Haskell+implementation, suitable for a server prototype:++```haskell++import Servant.Util.Dummy (sortBySpec, fieldSort)++getBooks :: ToServer GetBooks+getBooks sortingSpec = do+    let+      -- Correlate user input with fields of our response type+      sortingApp Book{..} =+          fieldSort @"name" bookName .*.+          fieldSort @"author" author .*.+          HNil+    sortBySpec sortingSpec sortingApp <$> allBooks+```++Since a list of fields that can participate in sorting is usually determined by the response+type, you can extract this fields list to an instance of the dedicated type family helper:++```haskell++type instance SortingParamBaseOf Book =+    ["name" ?: Isbn, "author" ?: Text]+type instance SortingParamProvidedOf Book =+    ["isbn" ?: Asc Isbn]++type GetBooks+    :> SortingParamsOf Book  -- same as the definition at the section's top+    =  Get '[JSON] [Book]++```++In case you need to construct a `SortingSpec` manually (for instance, to pass to a client handler),+take a look at [`Servant.Util.Combinators.Sorting.Construction`](src/Servant/Util/Combinators/Sorting/Construction.hs) module.+++### Filtering++This package provides support for many types of filtering: exact matching, comparisons,+text search; these are called automatic filters. Complex filtering conditions which do+not (and cannot) fall into one of the mentioned categories are also allowed and here they+are called manual filters. When user specifies multiple filters, their conjunction is+applied.++Let's consider filters on the previous example. Your API should be extended with+`FilteringParams` combinator which is pretty similar to `SortingParams`.++```haskell++type GetBooks+    :> FilteringParams ["isbn" ?: 'AutoFilter Isbn, "name" ?: 'AutoFilter Text]+    =  Get '[JSON] [Book]++```++Your endpoint implementation will be provided with `FilteringSpec` argument. Note that+this time parameters list contains not only parameter name and type, but also the type of+filter.++Just like for sorting, here you can use `SortingParamTypesOf` type family to reduce the+boilerplate.++Now you need to tell which automatic filter types are allowed for your types:++```haskell++type SupportedFilters Isbn = '[FilterMatching, FilterComparing]+type SupportedFilters Text = '[FilterMatching, FilterComparing]+-- the latter is already defined in this library++```++On the frontend side the following query parameters will be allowed:++* `isbn=12345` - plain matching filter.+* `isbn[eq]=12345` - same as above.+* `isbn[neq]=12345` - values not equal to the given one.+* `isbn[in]=[12345,23456]` - any value from the given list matches.+* `isbn[gt]=12345` - higher values are allowed.+* `isbn[lte]=12345` - the opposite to the previous predicate.+* `name[gte]=D&name[lt]=E` - everything starting with latter `D`.++Now let's suppose you need your server backend to support a much more complex+predicate: for instance, the book's name is longer than `10` characters. You can either define+your own filter or use a manual one; let's demonstrate the latter case:++```haskell++type GetBooks+    :> FilteringParams ["hasLongName" ?: ManualFilter Bool]+    =  Get '[JSON] [Book]++```++This way user can supply only `hasLongName=false` or `hasLongName=true` query parameter,+but the filter implementation can be arbitrarily complex.++In case we put `FilteringParams` with all the fields mentioned above into our `GET` method,+a dummy implementation of its handler may look like:++```haskell++getBooks :: ToServer GetBooks+getBooks filterSpec = do+    let+      filterApp Book{..} =+        filterOn @"isbn" isbn .*.  -- automatic fields require only the field+        filterOn @"name" bookName .*.+        manualFilter @"hasLongName"  -- manual filter requires a predicate+            (\needLongName -> (length bookName >= 10) == needLongName) .*.+        HNil++    filterBySpec filterSpec filterApp <$> getAllBooks++```++If for any reason you need to construct a `FilteringSpec` manually, take a look at+[`Servant.Util.Combinators.Filtering.Construction`](src/Servant/Util/Combinators/Filtering/Construction.hs) module.++### Pagination++Pagination is applied via `PaginationParams` combinator. It accepts a `settings` type argument,+which is currently just either `'DefPageSize n` or `'DefUnlimitedPageSize` that define+the default page size (defined statically in order to be reflected in documentation).++An endpoint supplied with this combinator starts accepting `offset` and `limit` query+parameters, both are optional.++Your endpoint implementation will be given a `PaginationSpec` object which can be applied+with an appropriate function.++```haskell++import Servant.Util (PaginationParams, PaginationSpec)+import Servant.Util.Dummy (paginate)++type GetBooks+    :> PaginationParams+    =  Get '[JSON] [Book]++getBooks :: ToServer GetBooks+getBooks pagination = paginate pagination <$> getAllBooks++```++### Logging++#### Problem++One can enable logging of incoming requests in a very simple way using [`logStdoutDev`](http://hackage.haskell.org/package/wai-extra-3.0.25/docs/Network-Wai-Middleware-RequestLogger.html#v:logStdoutDev)+function from `wai-extra` package.++Let's try it:+```sh+http POST :8090/books isbn:=12312 bookName='Some book' author=unknown password==qwerty123+```++Produced log:+```+POST /books+  Params: [("password","qwerty123")]+  Request Body: {"isbn": 12312, "bookName": "Some book", "author": "unknown"}+  Accept: application/json, */*+  Status: 201 Created 0.000086s+```++Note the problem: logs contain the password which makes them unusable in production.++And if we use+[`logStdout`](http://hackage.haskell.org/package/wai-extra-3.0.25/docs/Network-Wai-Middleware-RequestLogger.html#v:logStdout),+logs are missing the most part of the request data:++```+127.0.0.1 - - [29/Jan/2019:02:32:31 +0300] "POST /books?password=qwerty123 HTTP/1.1" 201 -+"" "HTTPie/0.9.8"+```++#### Proposed solution++A reasonable way to resolve this would be to display objects depending on their semantics.+This package provides an implementation of such logging, it can be used as follows:++```haskell++serveBooksServer :: IO ()+serveBooksServer =+    Warp.runSettings warpSettings $+    serverWithLogging loggingConfig (Proxy @BooksAPI) $ \sp ->+    serve sp booksHandlers+  where+    loggingConfig = ServantLogConfig putTextLn++```++This will wrap your API into an internal `LoggingAPI` combinator, resulting API `Proxy`+should be passed to `serve` method; meanwhile, handlers remain unchanged.++You will also need to provide `Buildable` instances for all request parameters:++```haskell++instance Buildable Isbn where+    build (Isbn i) = "isbn:" <> build i++instance Buildable Password where+    build _ = "<password>"++instance Buildable Book where+    build Book{..} =+        "{ isbn = " +| isbn |++        ", title = " +| bookName |++        ", author = " +| author |++        " }"++```++and `instance Buildable (ForResponseLog *)` for all types appearing as a response.+Note that semantics of `ForResponseLog` newtype wrapper is displaying a reasonable part of+a response: not too little to stay informative, not too large in order to keep logs small.++```haskell++instance Buildable (ForResponseLog Isbn) where+    build = buildForResponse++instance Buildable (ForResponseLog Book) where+    build = buildForResponse++instance Buildable (ForResponseLog [Book]) where+    build = buildListForResponse (take 5)++```++Now logs look like++```++POST Request #1+    :> books+    :> 'password' field: <password>+    :> request body: { isbn = isbn:12312, title = Some book, author = unknown }++    Response #1 OK 0.013415s > isbn:12312++```++## For Contributors++Please see [CONTRIBUTING.md](/.github/CONTRIBUTING.md) for more information.++## About Serokell++Servant-util is maintained and funded with :heart: by [Serokell](https://serokell.io/). The names and logo for Serokell are trademark of Serokell OÜ.++We love open source software! See [our other projects](https://serokell.io/community?utm_source=github) or [hire us](https://serokell.io/hire-us?utm_source=github) to design, develop and grow your idea!

@@ -0,0 +1,80 @@+module Books where++import Universum++import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.TH (defaultOptions, deriveJSON)+import Fmt (Buildable (..), (+|), (|+))+import qualified Network.Wai.Handler.Warp as Warp+import Servant (FromHttpApiData, Get, JSON, PostCreated, QueryParam, ReqBody, Server, serve,+                (:<|>) (..), (:>))++import Servant.Util++newtype Isbn = Isbn Word64+    deriving (Eq, Show, ToJSON, FromJSON)++data Book = Book+    { isbn     :: Isbn+    , bookName :: Text+    , author   :: Text+    }++deriveJSON defaultOptions 'Book++newtype Password = Password Text+    deriving (FromHttpApiData)++type GetBooks+    = Get '[JSON] [Book]++type AddBook+    =  QueryParam "password" Password+    :> ReqBody '[JSON] Book+    :> PostCreated '[JSON] Isbn++type BooksAPI = "books" :> (+    GetBooks :<|>+    AddBook+  )++booksHandlers :: Server BooksAPI+booksHandlers =+    (return [])+    :<|>+    (\_ book -> return (isbn book))++warpSettings :: Warp.Settings+warpSettings = Warp.defaultSettings+    & Warp.setHost "127.0.0.1"+    & Warp.setPort 8090++instance Buildable Isbn where+    build (Isbn i) = "isbn:" <> build i++instance Buildable Password where+    build _ = "<password>"++instance Buildable Book where+    build Book{..} =+        "{ isbn = " +| isbn |++        ", title = " +| bookName |++        ", author = " +| author |++        "}"++instance Buildable (ForResponseLog Isbn) where+    build = buildForResponse++instance Buildable (ForResponseLog Book) where+    build = buildForResponse++instance Buildable (ForResponseLog [Book]) where+    build = buildListForResponse (take 5)++serveBooksServer :: IO ()+serveBooksServer =+    Warp.runSettings warpSettings $+    serverWithLogging loggingConfig (Proxy @BooksAPI) $ \sp ->+    serve sp booksHandlers+  where+    loggingConfig = ServantLogConfig putTextLn

@@ -0,0 +1,6 @@+module Main where++import Universum++main :: IO ()+main = pass

@@ -0,0 +1,206 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9b39622564d5dbe44c295602cda018c1db31e30e2643f3713d8dc459084eef2c++name:           servant-util+version:        0.1.0+synopsis:       Servant servers utilities.+description:    Please see the README on GitHub at <https://github.com/serokell/servant-util#README.md>+category:       Web+homepage:       https://github.com/serokell/servant-util#readme+bug-reports:    https://github.com/serokell/servant-util/issues+author:         Serokell+maintainer:     hi@serokell.io+copyright:      2019 Serokell OÜ+license:        MPL-2.0+build-type:     Simple+extra-source-files:+    README.md+    CHANGES.md++source-repository head+  type: git+  location: https://github.com/serokell/servant-util++library+  exposed-modules:+      Servant.Util+      Servant.Util.Combinators+      Servant.Util.Combinators.ErrorResponses+      Servant.Util.Combinators.Filtering+      Servant.Util.Combinators.Filtering.Backend+      Servant.Util.Combinators.Filtering.Base+      Servant.Util.Combinators.Filtering.Client+      Servant.Util.Combinators.Filtering.Construction+      Servant.Util.Combinators.Filtering.Filters+      Servant.Util.Combinators.Filtering.Filters.General+      Servant.Util.Combinators.Filtering.Filters.Like+      Servant.Util.Combinators.Filtering.Getters+      Servant.Util.Combinators.Filtering.Logging+      Servant.Util.Combinators.Filtering.Server+      Servant.Util.Combinators.Filtering.Support+      Servant.Util.Combinators.Filtering.Swagger+      Servant.Util.Combinators.Logging+      Servant.Util.Combinators.Pagination+      Servant.Util.Combinators.Sorting+      Servant.Util.Combinators.Sorting.Arbitrary+      Servant.Util.Combinators.Sorting.Backend+      Servant.Util.Combinators.Sorting.Base+      Servant.Util.Combinators.Sorting.Client+      Servant.Util.Combinators.Sorting.Construction+      Servant.Util.Combinators.Sorting.Logging+      Servant.Util.Combinators.Sorting.Server+      Servant.Util.Combinators.Sorting.Swagger+      Servant.Util.Combinators.Tag+      Servant.Util.Common+      Servant.Util.Common.Common+      Servant.Util.Common.HList+      Servant.Util.Common.PolyKinds+      Servant.Util.Dummy+      Servant.Util.Dummy.Filtering+      Servant.Util.Dummy.Pagination+      Servant.Util.Dummy.Sorting+      Servant.Util.Error+      Servant.Util.Internal.Util+      Servant.Util.Stats+      Servant.Util.Swagger+      Servant.Util.Util+  other-modules:+      Paths_servant_util+  hs-source-dirs:+      src+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall+  build-tool-depends:+      autoexporter:autoexporter+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , containers+    , data-default+    , fmt+    , http-types+    , insert-ordered-containers+    , lens+    , megaparsec+    , mtl+    , pretty-terminal+    , reflection+    , regex-posix+    , safe-exceptions+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-swagger+    , servant-swagger-ui+    , servant-swagger-ui-core+    , swagger2+    , text+    , text-format+    , time+    , universum+    , wai+  default-language: Haskell2010++executable servant-util-examples+  main-is: Main.hs+  other-modules:+      Books+      Paths_servant_util+  hs-source-dirs:+      examples+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , containers+    , data-default+    , fmt+    , http-types+    , insert-ordered-containers+    , lens+    , megaparsec+    , mtl+    , pretty-terminal+    , reflection+    , regex-posix+    , safe-exceptions+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-swagger+    , servant-swagger-ui+    , servant-swagger-ui-core+    , servant-util+    , swagger2+    , text+    , text-format+    , time+    , universum+    , wai+    , wai-extra+    , warp+  default-language: Haskell2010++test-suite servant-util-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Spec+      Test.Servant.Filtering.GeneralSpec+      Test.Servant.Filtering.ImplSpec+      Test.Servant.Filtering.LikeSpec+      Test.Servant.Helpers+      Test.Servant.Pagination.ImplSpec+      Test.Servant.Sorting.ImplSpec+      Paths_servant_util+  hs-source-dirs:+      tests+  default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings OverloadedLabels PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators UndecidableInstances ViewPatterns TypeApplications+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , containers+    , data-default+    , fmt+    , hspec+    , hspec-expectations+    , http-client+    , http-types+    , insert-ordered-containers+    , lens+    , megaparsec+    , mtl+    , pretty-terminal+    , reflection+    , regex-posix+    , safe-exceptions+    , servant+    , servant-client+    , servant-client-core+    , servant-server+    , servant-swagger+    , servant-swagger-ui+    , servant-swagger-ui-core+    , servant-util+    , swagger2+    , text+    , text-format+    , time+    , universum+    , wai+    , warp+  default-language: Haskell2010

@@ -0,0 +1,9 @@+module Servant.Util+    ( module M+    ) where++import Servant.Util.Combinators as M+import Servant.Util.Common as M+import Servant.Util.Error as M+import Servant.Util.Stats as M+import Servant.Util.Swagger as M

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter -Wno-dodgy-exports -Wno-unused-imports #-}

@@ -0,0 +1,152 @@+module Servant.Util.Combinators.ErrorResponses+    ( ErrorDesc (..)+    , ErrorPartialDesc (..)+    , ErrorResponses+    , type (#:)+    , type ($)+    , ExceptionalResponses+    ) where++import Universum++import Control.Lens (at, (<>~), (?~))+import qualified Data.Swagger as S+import Data.Swagger.Declare (runDeclare)+import GHC.TypeLits (KnownSymbol, Symbol)+import Servant (HasServer (..), (:>))+import Servant.Client (HasClient (..))+import Servant.Swagger (HasSwagger (..))++import Servant.Util.Combinators.Logging+import Servant.Util.Common+++-- | Type-level information about an error response.+data ErrorDesc = ErrorDesc+    { erCode      :: Nat+    , erException :: Type+    , erDesc      :: Symbol+    }++-- | Like 'ErrorDesc', but without exception type yet.+data ErrorPartialDesc = ErrorPartialDesc+    { epdCode :: Nat+    , epdDesc :: Symbol+    }++{- | This combinator adds description of error response to swagger specification.++You have two ways to define this combinator:++* General:++@+ErrorResponses+   '[ 404 #! MyBackendException $+        "Not found"+    , 403 #! Int $+        "Operation is not permitted"+    ]+@++* When only one exception type is used:++@+ExceptionalResponses MyBackendException+   '[ 404 #: "Not found"+    , 403 #: "Operation is not permitted"+    ]+@++Note that if an error code was already defined further in endpoint definition,+it will be overwriten. For instance, 'Capture's define 400 error code (invalid+format); but in endpoint like @ErrorResponses (400 ...) :> Capture ... :> ...@+description for 400-error case provided by 'Capture' will be overwritten.++This combinator is transparent for server implementation.+-}+data ErrorResponses (errs :: [ErrorDesc])++type family ExceptionDesc err (codes :: [ErrorPartialDesc]) :: [ErrorDesc] where+    ExceptionDesc e '[] = '[]+    ExceptionDesc e ('ErrorPartialDesc code desc ': cs) =+        'ErrorDesc code e desc ': ExceptionDesc e cs++instance HasServer subApi ctx => HasServer (ErrorResponses errors :> subApi) ctx where+    type ServerT (ErrorResponses errors :> subApi) m = ServerT subApi m+    route _ = route (Proxy @subApi)+    hoistServerWithContext _ = hoistServerWithContext (Proxy @subApi)++instance HasClient m subApi => HasClient m (ErrorResponses errors :> subApi) where+    type Client m (ErrorResponses errors :> subApi) = Client m subApi+    clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi)+    hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst++instance HasLoggingServer config subApi ctx =>+         HasLoggingServer config (ErrorResponses errors :> subApi) ctx where+    routeWithLog = inRouteServer @(ErrorResponses errors :> LoggingApiRec config subApi) route id+++class KnownErrorCodes (errors :: [ErrorDesc]) where+    errorCodesToSwagger :: S.Swagger -> S.Swagger++instance KnownErrorCodes '[] where+    errorCodesToSwagger = id++instance (KnownNat code, KnownSymbol desc, S.ToSchema exc, KnownErrorCodes es) =>+         KnownErrorCodes ('ErrorDesc code exc desc ': es) where+    errorCodesToSwagger swagger = swagger+        & S.allOperations . S.responses . S.responses . at code ?~ S.Inline response+        & S.definitions <>~ defs+        & errorCodesToSwagger @es+      where+        code = fromIntegral (natVal @code Proxy)+        desc = symbolValT @desc+        (defs, excSchema) = runDeclare (S.declareSchemaRef (Proxy @exc)) mempty+        response = mempty+            & S.description .~ desc+            & S.schema ?~ excSchema++instance ( HasSwagger subApi+         , KnownErrorCodes errors+         ) => HasSwagger (ErrorResponses errors :> subApi) where+    toSwagger _ = toSwagger (Proxy @subApi) & errorCodesToSwagger @errors++---------------------------------------------------------------------------+-- Helpers+---------------------------------------------------------------------------++-- | A convenient alias for use with 'ErrorResponse'.+type (#!) = 'ErrorDesc++-- | An alias for 'ErrorResponse' which allows to mention an exception type+-- just once across all errors specification.+type ExceptionalResponses err codes = ErrorResponses $ ExceptionDesc err codes++-- | A convenient alias for use with 'ExceptionalResponse'.+type (#:) = 'ErrorPartialDesc++---------------------------------------------------------------------------+-- Test samples+---------------------------------------------------------------------------++data MyBackendException++type Sample1 = ExceptionalResponses MyBackendException+   '[ 404 #: "Not found"+    , 403 #: "Operation is not permitted"+    ]++_sample1 :: Sample1+_sample1 = error "Just checked that kind of Sample1 is *"++type Sample2 =+    ErrorResponses+    '[ 404 #! MyBackendException $+         "Not found"+     , 403 #! Int $+         "Operation is not permitted"+     ]++_sample2 :: Sample2+_sample2 = error "Just checked that kind of Sample2 is *"

@@ -0,0 +1,35 @@+-- | Allows complex filtering on specified fields.+module Servant.Util.Combinators.Filtering+    ( -- * General+      FilterKind (..)+    , FilteringParams+    , SupportedFilters+    , FilteringSpec (..)++      -- * Shortcuts+    , FilteringParamTypesOf+    , FilteringParamsOf+    , FilteringSpecOf++      -- * Filter types+    , FilterMatching (..)+    , FilterComparing (..)+    , FilterLike (..)+    , LikePattern (..)++    , NumericFilterTypes+    , TextFilterTypes+    , DatetimeFilterTypes++      -- * Manual construction+    , module Servant.Util.Combinators.Filtering.Construction+    ) where++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Client ()+import Servant.Util.Combinators.Filtering.Construction+import Servant.Util.Combinators.Filtering.Filters+import Servant.Util.Combinators.Filtering.Logging ()+import Servant.Util.Combinators.Filtering.Server ()+import Servant.Util.Combinators.Filtering.Support+import Servant.Util.Combinators.Filtering.Swagger ()

@@ -0,0 +1,196 @@+{-# LANGUAGE TypeInType #-}++-- | Provides base for filtering backend implementations.+module Servant.Util.Combinators.Filtering.Backend+    ( -- * Filtering backend+      FilterBackend (..)+    , AutoFilterImpl+    , FilteringApp (..)+    , AutoFilterSupport (..)+    , FilteringSpecApp+    , BackendApplySomeFilter+    , typeAutoFiltersSupport+    , backendApplyFilters++      -- * Server backend implementor API+    , filterOn+    , manualFilter+    ) where++import Universum++import Data.Typeable (gcast1)+import GHC.TypeLits (KnownSymbol)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Common++-- | Implementation of filtering backend.+class FilterBackend backend where++    -- | The part of object which we are filtering on,+    -- provided by server backend implementor.+    type AutoFilteredValue backend a++    -- | A resulting predicate.+    type MatchPredicate backend++-- | Implementation of auto filter we provide.+type AutoFilterImpl backend a =+    AutoFilteredValue backend a -> MatchPredicate backend++-- | How to apply a filter - what server backend implementor provides.+data FilteringApp backend param where+    AutoFilteringApp+        :: Typeable a+        => AutoFilteredValue backend a+        -> FilteringApp backend ('TyNamedParam name ('AutoFilter a))+    ManualFilteringApp+        :: Typeable a+        => (a -> MatchPredicate backend)+        -> FilteringApp backend ('TyNamedParam name ('ManualFilter a))++-- | Implementation of given auto filter type for Beam Postgres backend.+class (Typeable filter, FilterBackend backend) =>+      AutoFilterSupport backend filter a where+    -- | Apply given filter to a value.+    autoFilterSupport :: filter a -> AutoFilterImpl backend a++-- | Enlists a way to apply each of supported filters at target application backend.+type FilteringSpecApp backend params =+    HList (FilteringApp backend) params++-------------------------------------------------------------------------+-- Implementation+-------------------------------------------------------------------------++-- | Force a type family to be defined.+-- Primarily for prettier error messages.+type family AreFiltersDefined (a :: [Type -> Type]) :: Constraint where+    AreFiltersDefined '[] = Show (Int -> Int)+    AreFiltersDefined a = ()++-- | Lookup among filters supported for this type and prepare+-- an appropriate one for (deferred) application.+class TypeAutoFiltersSupport' backend (filters :: [Type -> Type]) a where+    typeAutoFiltersSupport' :: SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)++instance TypeAutoFiltersSupport' backend '[] a where+    typeAutoFiltersSupport' _ = Nothing++instance ( AutoFilterSupport backend filter a+         , TypeAutoFiltersSupport' backend filters a+         ) =>+         TypeAutoFiltersSupport' backend (filter ': filters) a where+    typeAutoFiltersSupport' sf@(SomeTypeAutoFilter filtr) = asum+        [ do+          Identity filter' <- gcast1 @_ @_ @filter (Identity filtr)+          return $ autoFilterSupport @backend filter'++        , typeAutoFiltersSupport' @backend @filters sf+        ]++type TypeAutoFiltersSupport backend a =+    ( AreFiltersDefined (SupportedFilters a)+    , TypeAutoFiltersSupport' backend (SupportedFilters a) a+    )++-- | Safely choose an appropriate filter from supported ones+-- and prepare it for application.+typeAutoFiltersSupport+    :: forall backend a.+       TypeAutoFiltersSupport backend a+    => SomeTypeAutoFilter a -> AutoFilterImpl backend a+typeAutoFiltersSupport filtr =+    typeAutoFiltersSupport' @backend @(SupportedFilters a) @a filtr+    ?: error "impossible, invariants of SomeTypeFilter are violated"++-- | Apply a filter for a specific type, evaluate whether a value matches or not.+class BackendApplyTypeFilter backend (fk :: Type -> FilterKind Type) a where+    backendApplyTypeFilter+        :: FilteringApp backend ('TyNamedParam name (fk a))+        -> TypeFilter fk a+        -> MatchPredicate backend++instance TypeAutoFiltersSupport backend a =>+         BackendApplyTypeFilter backend 'AutoFilter a where+    backendApplyTypeFilter (AutoFilteringApp field) (TypeAutoFilter filtr) =+        typeAutoFiltersSupport @backend filtr field++instance BackendApplyTypeFilter backend 'ManualFilter a where+    backendApplyTypeFilter (ManualFilteringApp app) (TypeManualFilter val) =+        app val++-- | Lookups for an appropriate filter application in a given 'FilteringSpecApp'+-- and applies it to a given filter.+class FilterBackend backend =>+      BackendApplySomeFilter backend (params :: [TyNamedFilter]) where+    backendApplySomeFilter'+        :: FilteringSpecApp backend params+        -> SomeFilter params+        -> Maybe (MatchPredicate backend)++instance FilterBackend backend =>+         BackendApplySomeFilter backend '[] where+    backendApplySomeFilter' _ _  = Nothing++instance ( Typeable fk, Typeable a+         , FilterBackend backend+         , KnownSymbol name+         , BackendApplyTypeFilter backend fk a+         , BackendApplySomeFilter backend params+         ) =>+         BackendApplySomeFilter backend ('TyNamedParam name (fk a) ': params) where+    backendApplySomeFilter' (app `HCons` fields) (SomeFilter name filtr) = asum+        [ do+          guard (symbolValT @name == name)+          let filtr' = castTypeFilter filtr+                    ?: error "Something is wrong, failed to cast filter!"+          return $ backendApplyTypeFilter app filtr'++        , backendApplySomeFilter' @backend @params fields (SomeFilter name filtr)+        ]++-- | Applies a filter to a set of response fields which matter for filtering.+backendApplySomeFilter+    :: BackendApplySomeFilter backend params+    => FilteringSpecApp backend params+    -> SomeFilter params+    -> MatchPredicate backend+backendApplySomeFilter app filtr =+    backendApplySomeFilter' app filtr ?: error "SomeFilter invariants violated"+    -- TODO: actually we're not protected from this error as soon as SomeFilter can be+    -- unwrapped and wrapped back++-- | Applies multiple filters to a set of response fields which matter for filtering.+backendApplyFilters+    :: forall backend params.+       BackendApplySomeFilter backend params+    => FilteringSpec params+    -> FilteringSpecApp backend params+    -> [MatchPredicate backend]+backendApplyFilters (FilteringSpec filters) app =+    map (backendApplySomeFilter app) filters++-------------------------------------------------------------------------+-- Building filters+-------------------------------------------------------------------------++-- | Implement an automatic filter.+-- User-provided filtering operation will do filter on this value.+filterOn+    :: forall name backend a.+       (Typeable a)+    => AutoFilteredValue backend a+    -> FilteringApp backend ('TyNamedParam name ('AutoFilter a))+filterOn = AutoFilteringApp++-- | Implement a manual filter.+-- You are provided with a value which user supplied and so you have+-- to construct a Beam predicate involving that value and relevant response fields.+manualFilter+    :: forall name backend a.+       (Typeable a)+    => (a -> MatchPredicate backend)+    -> FilteringApp backend ('TyNamedParam name ('ManualFilter a))+manualFilter = ManualFilteringApp

@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeInType    #-}++module Servant.Util.Combinators.Filtering.Base+    ( FilterKind (..)+    , TyNamedFilter+    , FilteringParams+    , SupportedFilters+    , FilteringSpec (..)+    , pattern DefFilteringCmd++    , SomeTypeAutoFilter (..)+    , TypeFilter (..)+    , SomeFilter (..)+    , extendSomeFilter+    , castTypeFilter++    , BuildableAutoFilter (..)+    , IsAutoFilter (..)+    , AreAutoFilters (..)+    , FilteringValueParser (..)+    , OpsDescriptions+    , parseFilteringValueAsIs+    , unsupportedFilteringValue+    , autoFiltersParsers++    , FilteringParamTypesOf+    , FilteringParamsOf+    , FilteringSpecOf+    ) where++import Universum++import qualified Data.Map as M+import Data.Typeable (cast)+import Fmt (Buildable (..), Builder)+import GHC.Exts (IsList)+import Servant (FromHttpApiData (..), ToHttpApiData (..))+import Servant.API (NoContent)++import Servant.Util.Common++-- | We support two kinds of filters.+data FilterKind a+    = AutoFilter a+      -- ^ Automatic filter where different operations are supported (eq, in, cmp).+      -- When applied to backend, only filtered value should be supplied.+    | ManualFilter a+      -- ^ User-provided value is passed to backend implementation as-is,+      -- and filtering on this value should be written manually.++type TyNamedFilter = TyNamedParam (FilterKind Type)++-- | Servant API combinator which enables filtering on given fields.+--+-- If type @T@ appears with a name @name@ in @params@ argument, then query parameters of+-- @name[op]=value@ format will be accepted, where @op@ is a filtering operation+-- (e.g. equal, not equal, greater) and @value@ is an item of type @T@ we filter against.+-- Multiple filters will form a conjunction.+--+-- List of allowed filtering operations depends on type @T@ and is specified by+-- 'SupportedFilters' type family.+--+-- Operation argument is optional, when not specified "equality" filter is applied.+--+-- Endpoint implementation will receive 'FilteringSpec' value which contains information+-- about all filters passed by user. You can later put it to an appropriate function+-- to apply filtering.+data FilteringParams (params :: [TyNamedFilter])++-- | For a type of field, get a list of supported filtering operations on this field.+type family SupportedFilters ty :: [Type -> Type]++-- | If no filtering command specified, think like if the given one was passed.+pattern DefFilteringCmd :: Text+pattern DefFilteringCmd = "eq"++-- | Parses text on the right side of "=" sign in query parameters.+newtype FilteringValueParser a = FilteringValueParser (Text -> Either Text a)+    deriving (Functor)++-- | Delegate to 'FromHttpApiData'.+parseFilteringValueAsIs :: FromHttpApiData a => FilteringValueParser a+parseFilteringValueAsIs = FilteringValueParser parseUrlPiece++unsupportedFilteringValue :: Text -> FilteringValueParser a+unsupportedFilteringValue errMsg = FilteringValueParser (\_ -> Left errMsg)++-- | For each filtering operation specifies a short plain-english description.+-- This is not a 'Map' to prevent developer-defined entries order.+type OpsDescriptions = [(Text, Text)]++-- | How auto filters appear in logging.+class BuildableAutoFilter (filter :: Type -> Type) where+    buildAutoFilter+        :: Buildable a => Text -> filter a -> Builder++-- | Application of a filter type to Servant API.+class (Typeable filter, BuildableAutoFilter filter) =>+      IsAutoFilter (filter :: Type -> Type) where++    -- | For each supported filtering operation specifies a short plain-english+    -- description.+    autoFilterEnglishOpsNames+        :: OpsDescriptions++    -- | For each supported filtering operation specifies parser for a filtering value.+    autoFilterParsers+        :: FromHttpApiData a+        => Proxy filter -> Map Text (FilteringValueParser (filter a))++    -- | Encode a filter to query parameter value.+    autoFilterEncode+        :: ToHttpApiData a+        => filter a -> (Text, Text)++    mapAutoFilterValue+        :: (a -> b) -> filter a -> filter b+    default mapAutoFilterValue+        :: Functor filter => (a -> b) -> filter a -> filter b+    mapAutoFilterValue = fmap++-- | Multi-version of 'IsFilter'.+class AreAutoFilters (filters :: [Type -> Type]) where+    mapFilterTypes+        :: (forall filter. IsAutoFilter filter => Proxy filter -> a)+        -> Proxy filters -> [a]++instance AreAutoFilters '[] where+    mapFilterTypes _ _ = []++instance (IsAutoFilter filter, AreAutoFilters filters) =>+         AreAutoFilters (filter ': filters) where+    mapFilterTypes mapper _ =+        mapper (Proxy @filter) : mapFilterTypes mapper (Proxy @filters)++-- | Gather parsers from multiple filters.+autoFiltersParsers+    :: forall filters a.+       (AreAutoFilters filters, FromHttpApiData a)+    => Map Text $ FilteringValueParser (SomeTypeAutoFilter a)+autoFiltersParsers =+    let parsers = mapFilterTypes (fmap (fmap SomeTypeAutoFilter) . autoFilterParsers)+                                 (Proxy @filters)+    in foldl' (M.unionWithKey onDuplicateCmd) mempty parsers+  where+    onDuplicateCmd cmd = error $ "Different filters have the same command " <> show cmd++-- | Some filter for an item of type @a@.+-- Filter type is guaranteed to be one of @SupportedFilters a@.+data SomeTypeAutoFilter a =+    forall filter. IsAutoFilter filter => SomeTypeAutoFilter (filter a)++instance Functor SomeTypeAutoFilter where+    fmap f (SomeTypeAutoFilter filtr) = SomeTypeAutoFilter (mapAutoFilterValue f filtr)++instance Buildable a => Buildable (Text, SomeTypeAutoFilter a) where+    build (name, SomeTypeAutoFilter f) = buildAutoFilter name f++-- | Some filter for an item of type @a@.+data TypeFilter (fk :: Type -> FilterKind Type) a where+    -- | One of automatic filters for type @a@.+    -- Filter type is guaranteed to be one of @SupportedFilters a@.+    TypeAutoFilter+        :: SomeTypeAutoFilter a -> TypeFilter 'AutoFilter a++    -- | Manually implemented filter.+    TypeManualFilter+        :: a -> TypeFilter 'ManualFilter a++castTypeFilter+    :: forall fk1 a1 fk2 a2.+       (Typeable fk1, Typeable a1, Typeable fk2, Typeable a2)+    => TypeFilter fk1 a1 -> Maybe (TypeFilter fk2 a2)+castTypeFilter = cast++-- | Some filter.+-- This filter is guaranteed to match a type which is mentioned in @params@.+data SomeFilter (params :: [TyNamedFilter]) where+    SomeFilter :: (Typeable fk, Typeable a) =>+        { sfName :: Text+        , sfFilter :: TypeFilter fk a+        } -> SomeFilter params++extendSomeFilter :: SomeFilter params -> SomeFilter (param ': params)+extendSomeFilter (SomeFilter f n) = SomeFilter f n++-- | This is what you get in endpoint implementation, it contains all filters+-- supplied by a user.+-- Invariant: each filter correspond to some type mentioned in @params@.+newtype FilteringSpec (params :: [TyNamedFilter]) = FilteringSpec [SomeFilter params]+    deriving (IsList)++-- | For a given return type of an endpoint get corresponding filtering params.+-- This mapping is sensible, since we usually allow to filter only on fields appearing in+-- endpoint's response.+type family FilteringParamTypesOf a :: [TyNamedFilter]++-- | This you will most probably want to specify in API.+type FilteringParamsOf a = FilteringParams (FilteringParamTypesOf a)++-- | This you will most probably want to specify in an endpoint implementation.+type FilteringSpecOf a = FilteringSpec (FilteringParamTypesOf a)++type instance FilteringParamTypesOf NoContent = '[]

@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Filtering.Client () where++import Universum hiding (filter)++import Data.Typeable (cast)+import GHC.TypeLits (KnownSymbol)+import Servant (ToHttpApiData (..), toQueryParam, (:>))+import Servant.Client (HasClient (..))+import Servant.Client.Core.Request (Request, appendToQueryString)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Support ()+import Servant.Util.Common++-------------------------------------------------------------------------+-- Client+-------------------------------------------------------------------------++-- | For given filter return operation name and encoded value.+typeFilterToReq :: ToHttpApiData a => TypeFilter fk a -> (Text, Text)+typeFilterToReq = \case+    TypeAutoFilter (SomeTypeAutoFilter filter) -> autoFilterEncode filter+    TypeManualFilter val                       -> (DefFilteringCmd, toQueryParam val)++-- | Apply filter to a client request being built.+class SomeFilterToReq params where+    someFilterToReq :: SomeFilter params -> Request -> Request++instance SomeFilterToReq '[] where+    someFilterToReq = error "Something got wrong"++instance ( KnownSymbol name+         , Typeable (fk :: * -> FilterKind *)+         , Typeable a+         , ToHttpApiData a+         , SomeFilterToReq params+         ) =>+         SomeFilterToReq ('TyNamedParam name (fk a) ': params) where+    someFilterToReq SomeFilter{..}+        | symbolValT @name == sfName =+            let filter :: TypeFilter fk a = cast sfFilter ?: error "Failed to cast filter"+                (op, value) = typeFilterToReq filter+                keymod = if op == DefFilteringCmd then "" else "[" <> op <> "]"+                key = sfName <> keymod+            in appendToQueryString key (Just value)+        | otherwise =+            someFilterToReq @params SomeFilter{..}++instance (HasClient m subApi, SomeFilterToReq params) =>+         HasClient m (FilteringParams params :> subApi) where+    type Client m (FilteringParams params :> subApi) =+        FilteringSpec params -> Client m subApi+    clientWithRoute mp _ req (FilteringSpec filters) =+        clientWithRoute mp (Proxy @subApi) (foldr someFilterToReq req filters)+    hoistClientMonad pm _ hst subCli = hoistClientMonad pm (Proxy @subApi) hst . subCli

@@ -0,0 +1,193 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists  #-}+{-# LANGUAGE TypeInType       #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Helpers for defining filters manually.+module Servant.Util.Combinators.Filtering.Construction+    ( noFilters+    , mkFilteringSpec+    , (?/)+    , (?/=)+    , (?/<)+    , (?/>)+    , (?/<=)+    , (?/>=)+    , (?/~)+    , textLike+    , textILike+    , textContains+    , textIContains+    ) where++import Universum hiding (filter)++import Data.Coerce (coerce)+import Data.Default (Default (..))+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Filters+import Servant.Util.Combinators.Filtering.Support ()+import Servant.Util.Common++{- | Build a filtering specification.+Used along with "OverloadedLabels" extension and @($)@ / @($=)@ operators.++Example:++@+filteringSpec :: FilteringSpec ["id" ?: 'AutoFilter Int, "desc" ?: 'ManualFilter Text]+filteringSpec = mkFilteringSpec+    [ -- Constructing an auto filter+    , #id ?/ FilterGT 0++      -- The following two lines are equivalent+    , #id ?/ FilterMatching 5+    , #id ?/= 5++      -- Constructing a manually implemented filter+    , #desc ?/~ "You are my sunshine, my only sunshine"+    ]+@++You can freely use 'GHC.Exts.fromList' instead of this function.+-}+mkFilteringSpec :: [SomeFilter params] -> FilteringSpec params+mkFilteringSpec = FilteringSpec++-- | By default 'noFilters' is used.+instance Default (FilteringSpec params) where+    def = noFilters++-- | Return all items.+noFilters :: FilteringSpec params+noFilters = FilteringSpec []++type family IsSupportedFilter filter a :: Constraint where+    IsSupportedFilter filter a =+        If (Elem filter (SupportedFilters a))+          (() :: Constraint)+          (TypeError+              ( 'Text "Filter '" ':<>: 'ShowType filter ':<>:+                'Text "' is not supported for '" ':<>: 'ShowType a ':<>:+                'Text "' type"+              )+          )++-- | Safely construct 'TypeFilter'.+class MkTypeFilter filter fk a where+    mkTypeFilter :: filter -> TypeFilter fk a++instance ( filter ~ filterType a+         , IsAutoFilter filterType+         , IsSupportedFilter filterType a+         ) =>+         MkTypeFilter filter 'AutoFilter a where+    mkTypeFilter filter = TypeAutoFilter (SomeTypeAutoFilter filter)++instance (filter ~ a) => MkTypeFilter filter 'ManualFilter a where+    mkTypeFilter = TypeManualFilter++-- | Safely construct 'SomeFilter'.+class MkSomeFilter name filter (origParams :: [TyNamedFilter]) (params :: [TyNamedFilter]) where+    mkSomeFilter :: filter -> SomeFilter params++instance TypeError ('Text "Unknown filter " ':<>: 'ShowType name ':$$:+                    'Text "Allowed ones here: " ':<>: 'ShowType (TyNamedParamsNames origParams)) =>+         MkSomeFilter name filter origParams '[] where+    mkSomeFilter = error ":shrug:"++instance {-# OVERLAPPING #-}+         (MkTypeFilter filter fk a, KnownSymbol name, Typeable fk, Typeable a) =>+         MkSomeFilter name filter origParams ('TyNamedParam name (fk a) ': params) where+    mkSomeFilter filter =+        SomeFilter+        { sfName = symbolValT @name+        , sfFilter = mkTypeFilter @filter @fk @a filter+        }++instance MkSomeFilter name filter origParams params =>+         MkSomeFilter name filter origParams (param ': params) where+    mkSomeFilter filter = coerce $ mkSomeFilter @name @filter @origParams @params filter++-- | "Filter by" operation.+-- Wraps a filter corresponding to the given name into 'SomeFilter' which can later be+-- passed to 'mkSomeFilter'.+(?/)+    :: forall name params filter.+       MkSomeFilter name filter params params+    => NameLabel name -> filter -> SomeFilter params+(?/) _ = mkSomeFilter @name @_ @params+infixr 0 ?/++-- | "Filter by matching" operation.+(?/=)+    :: forall name params filter.+       MkSomeFilter name (FilterMatching filter) params params+    => NameLabel name -> filter -> SomeFilter params+l ?/= f = l ?/ FilterMatching f+infixr 0 ?/=++-- | Make a comparing filter.+(?/>), (?/<), (?/>=), (?/<=)+    :: forall name params filter.+       MkSomeFilter name (FilterComparing filter) params params+    => NameLabel name -> filter -> SomeFilter params+l ?/> f = l ?/ FilterGT f+l ?/< f = l ?/ FilterLT f+l ?/>= f = l ?/ FilterGTE f+l ?/<= f = l ?/ FilterLTE f+infixr 0 ?/>+infixr 0 ?/<+infixr 0 ?/>=+infixr 0 ?/<=++-- | Make a simple POSIX regex filter.+textLike+    :: forall name params text.+       (MkSomeFilter name (FilterLike text) params params, HasCallStack)+    => NameLabel name -> LText -> SomeFilter params+l `textLike` p = l ?/ FilterLike @text (CaseSensitivity True) (mkLikePatternUnsafe p)+infixr 0 `textLike`++-- | Make a simple POSIX regex case-insensitive filter.+textILike+    :: forall name params text.+       (MkSomeFilter name (FilterLike text) params params, HasCallStack)+    => NameLabel name -> LText -> SomeFilter params+l `textILike` p = l ?/ FilterLike @text (CaseSensitivity False) (mkLikePatternUnsafe p)+infixr 0 `textILike`++-- | Make a filter that checks whether the given text is included.+textContains+    :: forall name params text.+       MkSomeFilter name (FilterLike text) params params+    => NameLabel name -> Text -> SomeFilter params+l `textContains` p = l ?/ filterContains @text (CaseSensitivity True) p+infixr 0 `textContains`++-- | Make a filter that checks whether the given text is included,+-- case-insensitive.+textIContains+    :: forall name params text.+       MkSomeFilter name (FilterLike text) params params+    => NameLabel name -> Text -> SomeFilter params+l `textIContains` p = l ?/ filterContains @text (CaseSensitivity False) p+infixr 0 `textIContains`++-- | Construct a (manual) filter from a value with the same representation as expected one.+-- Helpful when newtypes are heavely used in API parameters.+(?/~)+    :: forall name filter' params filter.+       (MkSomeFilter name filter' params params, Coercible filter filter')+    => NameLabel name -> filter -> SomeFilter params+l ?/~ f = l ?/ coerce @_ @filter' f++_sample :: FilteringSpec ["id" ?: 'AutoFilter Int, "desc" ?: 'ManualFilter Text]+_sample =+    [ #id ?/ FilterMatching 5+    , #id ?/= 5+    , #desc ?/ "Kek"+    , #id ?/ FilterGT 3+    ]

@@ -0,0 +1,2 @@+-- | Various filter types.+{-# OPTIONS_GHC -F -pgmF autoexporter -Wno-dodgy-exports -Wno-unused-imports #-}

@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveFunctor #-}++module Servant.Util.Combinators.Filtering.Filters.General+    ( FilterMatching (..)+    , FilterComparing (..)+    ) where++import Universum++import qualified Data.Map as M+import qualified Data.Text as T+import Fmt (build, listF)+import Servant (FromHttpApiData (..), ToHttpApiData (..))++import Servant.Util.Combinators.Filtering.Base++-------------------------------------------------------------------------+-- Filter types+-------------------------------------------------------------------------++-- | Support for @(==)@, @(/=)@ and @IN <values list>@ operations.+data FilterMatching a+    = FilterMatching a+    | FilterNotMatching a+    | FilterItemsIn [a]+    deriving (Functor)++instance BuildableAutoFilter FilterMatching where+    buildAutoFilter name = \case+        FilterMatching v    -> build name <> " = " <> build v+        FilterNotMatching v -> build name <> " /= " <> build v+        FilterItemsIn v     -> build name <> " ∊ " <> listF v++instance IsAutoFilter FilterMatching where+    autoFilterEnglishOpsNames =+        [ (DefFilteringCmd, "is equal to, _default operation_")+        , ("neq", "is not equal to")+        , ("in", "is one of")+        ]++    autoFilterParsers _ = M.fromList+        [ ( DefFilteringCmd+          , FilterMatching <$> parseFilteringValueAsIs+          )+        , ( "neq"+          , FilterNotMatching <$> parseFilteringValueAsIs+          )+        , ( "in"+          , FilterItemsIn <$> FilteringValueParser parseValuesList+          )+        ]+      where+        parseValuesList text = do+            text' <- maybeToRight ("Expected comma-separated list within '[]'") $+                T.stripPrefix "[" text >>= T.stripSuffix "]"+            let vals = T.splitOn "," text'+            mapM parseUrlPiece vals++    autoFilterEncode = \case+        FilterMatching v    -> (DefFilteringCmd, toQueryParam v)+        FilterNotMatching v -> ("neq", toQueryParam v)+        FilterItemsIn vs    -> ("in", "[" <> T.intercalate "," (map toQueryParam vs) <> "]")+++-- | Support for @(<)@, @(>)@, @(<=)@ and @(>=)@ operations.+data FilterComparing a+    = FilterGT a+    | FilterLT a+    | FilterGTE a+    | FilterLTE a+    deriving (Functor)++instance BuildableAutoFilter FilterComparing where+    buildAutoFilter name = \case+        FilterGT v  -> build name <> " > " <> build v+        FilterLT v  -> build name <> " < " <> build v+        FilterGTE v -> build name <> " >= " <> build v+        FilterLTE v -> build name <> " <= " <> build v++instance IsAutoFilter FilterComparing where+    autoFilterEnglishOpsNames =+        [ ("gt", "is greater")+        , ("lt", "is less")+        , ("gte", "is greater or equal")+        , ("lte", "is less or equal")+        ]++    autoFilterParsers _ = M.fromList+        [ ( "gt"+          , FilterGT <$> parseFilteringValueAsIs+          )+        , ( "lt"+          , FilterLT <$> parseFilteringValueAsIs+          )+        , ( "gte"+          , FilterGTE <$> parseFilteringValueAsIs+          )+        , ( "lte"+          , FilterLTE <$> parseFilteringValueAsIs+          )+        ]++    autoFilterEncode = \case+        FilterGT v  -> ("gt", toQueryParam v)+        FilterLT v  -> ("lt", toQueryParam v)+        FilterGTE v -> ("gte", toQueryParam v)+        FilterLTE v -> ("lte", toQueryParam v)+++-------------------------------------------------------------------------+-- Basic filters support+-------------------------------------------------------------------------

@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveFunctor #-}++module Servant.Util.Combinators.Filtering.Filters.Like+    ( pattern Esc+    , CaseSensitivity (..)+    , mkLikePattern+    , LikePattern (..)+    , FilterLike (..)+    , mkLikePatternUnsafe+    , filterContains+    ) where++import Universum++import qualified Data.Map as M+import qualified Data.Text.Lazy as LT+import Fmt (Buildable (..), (+|), (|+))+import Servant (FromHttpApiData (..), ToHttpApiData (..))+import System.Console.Pretty (Color (..), Style (..), color, style)++import Servant.Util.Combinators.Filtering.Base++-- | Whether search is case-sensitive.+newtype CaseSensitivity = CaseSensitivity Bool++instance Buildable CaseSensitivity where+    build (CaseSensitivity cs)+        | cs = ""+        | otherwise = "(case-insensitive)"++-- | Simple regexp pattern, @.@ and @*@ signed will be considered.+-- Escaping is performed via prefixing with backslash.+newtype LikePattern = LikePatternUnsafe+    { unLikePattern :: LText+    }++pattern Esc :: Char+pattern Esc = '\\'++escapedChar :: Char -> LText+escapedChar c = LT.pack [Esc, c]++mkLikePattern :: LText -> Either Text LikePattern+mkLikePattern txt = do+    if valid (toString txt)+        then pass+        else Left "Single escape character ('\') is not allowed"+    return (LikePatternUnsafe txt)+  where+    valid = \case+        Esc : Esc : r -> valid r+        Esc : '.' : r -> valid r+        Esc : '*' : r -> valid r+        Esc : _       -> False+        _ : r         -> valid r+        []            -> True++mkLikePatternUnsafe :: LText -> LikePattern+mkLikePatternUnsafe = either error id . mkLikePattern++instance IsString LikePattern where+    fromString = either error id . mkLikePattern . fromString++instance Buildable LikePattern where+    build (LikePatternUnsafe p) = like |+ " " +| p |+ ""+      where+        like = style Faint (color White "like") :: Text++-- | Support for SQL's LIKE syntax.+data FilterLike a+    = FilterLike CaseSensitivity LikePattern+    deriving (Functor)++-- | Construct a filter that matches when text contains given substring.+filterContains :: CaseSensitivity -> Text -> FilterLike a+filterContains cs pat =+    FilterLike cs (LikePatternUnsafe $ asContains $ LT.fromStrict pat)+  where+    asContains t = t+        & LT.replace "." (escapedChar '.')+        & LT.replace "*" (escapedChar '*')+        & LT.replace (LT.singleton Esc) (escapedChar Esc)+        & LT.cons '*'+        & flip LT.snoc '*'++instance BuildableAutoFilter FilterLike where+    buildAutoFilter name = \case+        FilterLike cs f -> build name <> " " <> build f <> " " <> build cs++instance IsAutoFilter FilterLike where+    autoFilterEnglishOpsNames =+        [ ("like", "regex match (`.` for any char, `*` for any substring)")+        , ("ilike", "case-insensitive regex")+        , ("contains", "contains text, requires no escaping")+        , ("icontains", "case-insensitive 'contains text'")+        ]++    autoFilterParsers _ = M.fromList+        [ ( "like"+          , FilterLike (CaseSensitivity True) <$> parseLikePattern+          )+        , ( "ilike"+          , FilterLike (CaseSensitivity False) <$> parseLikePattern+          )+        , ( "contains"+          , filterContains (CaseSensitivity True) <$> parseFilteringValueAsIs+          )+        , ( "icontains"+          , filterContains (CaseSensitivity False) <$> parseFilteringValueAsIs+          )+        ]+      where+        parseLikePattern = FilteringValueParser $ \t -> do+            pat <- parseUrlPiece t+            mkLikePattern pat++    autoFilterEncode = \case+        FilterLike cs (unLikePattern -> pat)+            | CaseSensitivity True <- cs+                -> ("like", toQueryParam pat)+            | otherwise+                -> ("ilike", toQueryParam pat)

@@ -0,0 +1,43 @@+{-# LANGUAGE TypeInType #-}++-- | Filter getters.+--+-- Allows to get a value passed by user to a manual filter.+-- Extracing auto filters is not allowed as soon as they are too complex+-- to make anything useful with them anyway.+module Servant.Util.Combinators.Filtering.Getters+    ( manualFilterValue+    ) where++import Universum++import GHC.TypeLits (ErrorMessage (..), KnownSymbol, TypeError)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Common++type family UnManualFilter (fk :: FilterKind k) :: k where+    UnManualFilter ('ManualFilter a) = a+    UnManualFilter ('AutoFilter a) =+        TypeError ('Text "Getting an auto filter is not allowed")++-- | Extract a value from manual filter.+manualFilterValue+    :: forall name params filter filterKind.+       ( filterKind ~ LookupParam "filter" name (params :: [TyNamedFilter])+       , filter ~ UnManualFilter filterKind+       , Typeable filter+       , KnownSymbol name+       )+    => NameLabel name -> FilteringSpec params -> [filter]+manualFilterValue _ (FilteringSpec filters) =+    -- Probably this function should return @Maybe filter@ instead,+    -- but that requires some work (prohibiting specifying the same+    -- manual filter twice in server and in manual filters construction),+    -- and use cases for this getter are not clear yet.++    catMaybes $ filters <&> \SomeFilter{..} ->+        guard (sfName == symbolValT @name) $>+        case castTypeFilter @_ @_ @'ManualFilter sfFilter of+            Just (TypeManualFilter v) -> v+            _                         -> error "Failed to cast filter"

@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Filtering.Logging+    ( BuildSomeFilter (..)+    ) where++import Universum++import qualified Data.List as L+import Data.Typeable (cast)+import Fmt (Buildable (..), Builder, fmt, (+|), (|+))+import GHC.TypeLits (KnownSymbol)+import Servant (HasServer (..), (:>))++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Server+import Servant.Util.Combinators.Logging+import Servant.Util.Common++-- | Print a filter as it should appear in logs.+class BuildSomeFilter params where+    buildSomeFilter' :: SomeFilter params -> Maybe Builder++instance BuildSomeFilter '[] where+    buildSomeFilter' _ = Nothing++instance ( KnownSymbol name+         , Typeable a+         , Buildable a+         , BuildSomeFilter params+         ) => BuildSomeFilter ('TyNamedParam name ('AutoFilter a) ': params) where+    buildSomeFilter' SomeFilter{..} = asum+        [ do+          guard (name == sfName)+          filtr :: TypeFilter 'AutoFilter a <- cast sfFilter+          return $ case filtr of TypeAutoFilter f -> build (name, f)++        , buildSomeFilter' @params SomeFilter{..}+        ]+      where+        name = symbolValT @name++instance ( KnownSymbol name+         , Typeable a+         , Buildable a+         , BuildSomeFilter params+         ) => BuildSomeFilter ('TyNamedParam name ('ManualFilter a) ': params) where+    buildSomeFilter' SomeFilter{..} = asum+        [ do+          guard (name == sfName)+          filtr :: TypeFilter 'ManualFilter a <- cast sfFilter+          return $ case filtr of TypeManualFilter v -> name |+ ": " +| v |+ ""++        , buildSomeFilter' @params SomeFilter{..}+        ]+      where+        name = symbolValT @name++buildSomeFilter :: BuildSomeFilter params => SomeFilter params -> Builder+buildSomeFilter sf = buildSomeFilter' sf ?: error "Failed to build some filter"++instance ( HasLoggingServer config subApi ctx+         , AreFilteringParams params+         , ReifyParamsNames params+         , BuildSomeFilter params+         ) =>+         HasLoggingServer config (FilteringParams params :> subApi) ctx where+    routeWithLog =+        inRouteServer @(FilteringParams params :> LoggingApiRec config subApi) route $+        \(paramsInfo, handler) filtering@(FilteringSpec params) ->+            let paramLog+                  | null params = "no filters"+                  | otherwise = fmt . mconcat $+                                L.intersperse ", " (map buildSomeFilter params)+            in (addParamLogInfo paramLog paramsInfo, handler filtering)

@@ -0,0 +1,141 @@+{-# LANGUAGE TypeInType #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Filtering.Server+    ( AreFilteringParams+    ) where++import Universum++import qualified Data.Map as M+import qualified Data.Text as T+import Fmt (Buildable (..))+import GHC.TypeLits (KnownSymbol)+import Network.HTTP.Types.URI (QueryText, parseQueryText)+import Network.Wai.Internal (rawQueryString)+import Servant (FromHttpApiData (..), HasServer (..), ServerError (..), err400, (:>))+import Servant.Server.Internal (addParameterCheck, delayedFailFatal, withRequest)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Common++-- | Try to parse query key assuming that the specified field to filter on+-- should match the given name.+-- If specified filter does not match the given one, 'Nothing' is returned.+-- Otherwise operation name is extracted and returned.+parseQueryKey :: Text -> Text -> Maybe Text+parseQueryKey field key = do+    remainder <- T.stripPrefix field key+    asum+        [ guard (null remainder) $> DefFilteringCmd+        , T.stripPrefix "[" <=< T.stripSuffix "]" $ remainder+        , T.stripPrefix "_" remainder+        ]++-- | Try to parse given query parameter as filter applicable to type @a@.+-- If the parameter is not recognized as filtering one, 'Nothing' is returned.+-- Otherwise it is parsed and any potential errors are reported as-is.+parseAutoTypeFilteringParam+    :: forall a (filters :: [Type -> Type]).+       (filters ~ SupportedFilters a, AreAutoFilters filters, FromHttpApiData a)+    => Text -> Text -> Text -> Maybe (Either Text $ SomeTypeAutoFilter a)+parseAutoTypeFilteringParam field key val = do+    op <- parseQueryKey field key+    let parsersPerOp = autoFiltersParsers @filters @a+    let allowedOps = M.keys parsersPerOp++    pure $ do+        FilteringValueParser parser <- case M.lookup op parsersPerOp of+            Nothing -> Left $ "Unsupported filtering command " <> show op <> ". \+                              \Available commands: " <>+                              (T.intercalate ", " $ map show allowedOps)+            Just parser -> pure parser++        parser val+{-# INLINE parseAutoTypeFilteringParam #-}++-- | Application of filter params.+class AreFilteringParams (params :: [TyNamedFilter]) where+    -- | Try to parser given query parameter as a filter corresponding to @params@+    -- configuration.+    -- If the query parameter is not recognized as filtering one, 'Nothing' is returned.+    -- Otherwise it is parsed and any potential errors are reported as-is.+    parseFilteringParam :: Text -> Text -> Maybe (Either Text $ SomeFilter params)++instance AreFilteringParams '[] where+    parseFilteringParam _ _ = Nothing+    {-# INLINE parseFilteringParam #-}++instance ( FromHttpApiData ty+         , Typeable ty+         , AreAutoFilters (SupportedFilters ty)+         , KnownSymbol name+         , AreFilteringParams params+         ) =>+         AreFilteringParams ('TyNamedParam name ('AutoFilter ty) ': params) where+    parseFilteringParam key val = asum+        [ fmap (fmap (SomeFilter name . TypeAutoFilter)) $+            parseAutoTypeFilteringParam @ty (symbolValT @name) key val++        , fmap (fmap extendSomeFilter) $+            parseFilteringParam @params key val+        ]+      where+        name = symbolValT @name+    {-# INLINE parseFilteringParam #-}++instance ( FromHttpApiData ty+         , Buildable ty+         , Typeable ty+         , KnownSymbol name+         , AreFilteringParams params+         ) =>+         AreFilteringParams ('TyNamedParam name ('ManualFilter ty) ': params) where+    parseFilteringParam key val = asum+        [ guard (name == key) $> do+            v <- parseUrlPiece @ty val+            return $ SomeFilter+                { sfName = name+                , sfFilter = TypeManualFilter v+                }++        , fmap (fmap extendSomeFilter) $+            parseFilteringParam @params key val+        ]+      where+        name = symbolValT @name+    {-# INLINE parseFilteringParam #-}++extractQueryParamsFilters+    :: forall (params :: [TyNamedFilter]).+       (AreFilteringParams params)+    => QueryText -> Either Text [SomeFilter params]+extractQueryParamsFilters qt = sequence $ do+    (key, mvalue) <- qt+    Just value <- pure mvalue+    Just aFilter <- pure $ parseFilteringParam @params key value+    return aFilter+{-# INLINE extractQueryParamsFilters #-}++instance ( HasServer subApi ctx+         , AreFilteringParams params+         ) =>+         HasServer (FilteringParams params :> subApi) ctx where++    type ServerT (FilteringParams params :> subApi) m =+        FilteringSpec params -> ServerT subApi m++    route _ ctx delayed =+        route (Proxy @subApi) ctx $+        addParameterCheck delayed (withRequest extractParams)+      where+        extractParams req =+            let -- Copy-pasted from 'instance HasServer QueryParam'+                queryText = parseQueryText (rawQueryString req)+            in fmap FilteringSpec . eitherToDelayed $+                   extractQueryParamsFilters @params queryText+        eitherToDelayed = \case+            Left err -> delayedFailFatal err400{ errBody = encodeUtf8 err }+            Right x  -> pure x++    hoistServerWithContext _ pm hst s = hoistServerWithContext (Proxy @subApi) pm hst . s

@@ -0,0 +1,50 @@+-- | Auto filters support for basic types.+module Servant.Util.Combinators.Filtering.Support+    ( NumericFilterTypes+    , TextFilterTypes+    , DatetimeFilterTypes+    , AllFilterTypes+    ) where++import Universum++import Data.Time.Calendar (Day)+import Data.Time.Clock (UTCTime)+import Data.Time.LocalTime (LocalTime)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Filters+++type NumericFilterTypes = [FilterMatching, FilterComparing]+type TextFilterTypes = [FilterMatching, FilterComparing, FilterLike]+type ByteStringFilterTypes = [FilterMatching, FilterComparing]+type DatetimeFilterTypes = '[FilterComparing]+type AllFilterTypes = '[FilterMatching, FilterComparing, FilterLike]++type instance SupportedFilters () = '[]++type instance SupportedFilters Bool = '[FilterMatching]++type instance SupportedFilters Integer = NumericFilterTypes+type instance SupportedFilters Int = NumericFilterTypes+type instance SupportedFilters Int8 = NumericFilterTypes+type instance SupportedFilters Int16 = NumericFilterTypes+type instance SupportedFilters Int32 = NumericFilterTypes+type instance SupportedFilters Int64 = NumericFilterTypes+type instance SupportedFilters Natural = NumericFilterTypes+type instance SupportedFilters Word = NumericFilterTypes+type instance SupportedFilters Word8 = NumericFilterTypes+type instance SupportedFilters Word16 = NumericFilterTypes+type instance SupportedFilters Word32 = NumericFilterTypes+type instance SupportedFilters Word64 = NumericFilterTypes+type instance SupportedFilters Float = NumericFilterTypes+type instance SupportedFilters Double = NumericFilterTypes++type instance SupportedFilters Char = [FilterMatching, FilterComparing]+type instance SupportedFilters Text = TextFilterTypes+type instance SupportedFilters ByteString = ByteStringFilterTypes++type instance SupportedFilters UTCTime = DatetimeFilterTypes+type instance SupportedFilters LocalTime = DatetimeFilterTypes+type instance SupportedFilters Day = NumericFilterTypes

@@ -0,0 +1,111 @@+{-# LANGUAGE TypeInType #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Filtering.Swagger () where++import Universum++import Control.Lens ((<>~))+import qualified Data.Swagger as S+import qualified Data.Text as T+import GHC.TypeLits (KnownSymbol)+import Servant.API ((:>))+import Servant.Swagger (HasSwagger (..))++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Common+import Servant.Util.Swagger++-- | Make a 'S.Param' for a filtering query parameter.+filterSwaggerParam :: forall a. S.ToParamSchema a => Text -> Text -> S.Param+filterSwaggerParam name desc =+    S.Param+    { S._paramName = name+    , S._paramDescription = Just desc+    , S._paramRequired = Just False+    , S._paramSchema = S.ParamOther S.ParamOtherSchema+        { S._paramOtherSchemaIn = S.ParamQuery+        , S._paramOtherSchemaAllowEmptyValue = Just True+        , S._paramOtherSchemaParamSchema = S.toParamSchema (Proxy @a)+        }+    }++parenValueDesc :: forall a. KnownSymbol (ParamDescription a) => Text+parenValueDesc = "(" <> stripTrailingDot (symbolValT @(ParamDescription a)) <> ")"+  where+    stripTrailingDot t = T.stripSuffix "." t ?: t++autoFilterDesc :: forall a. KnownSymbol (ParamDescription a) => OpsDescriptions -> Text+autoFilterDesc ops = fullDesc+  where+    opsDesc+        | [(DefFilteringCmd, _)] <- ops = []+        | otherwise =+            "You can specify a custom filtering operation in `param[op]=value` \+            \or `param_op=value` format." :+            "Allowed operations:" :+            (ops <&> \(op, engDesc) -> "* `" <> op <> "` (" <> engDesc <> ")")++    noDefaultOpWarn =+        [ () | Nothing <- pure $ find ((DefFilteringCmd == ) . fst) ops ]+      *>+        [ ""+        , "_NB: Specifying filtering operation is mandatory for this parameter!_"+        ]++    fullDesc = unlines $+        [ "Filter values according to provided operation " <> parenValueDesc @a <> "."+        ] ++ opsDesc+          ++ noDefaultOpWarn++manualFilterDesc :: forall a. KnownSymbol (ParamDescription a) => Text+manualFilterDesc =+    "Leave values matching given parameter " <> parenValueDesc @a <> "."++-- | Gather swagger params for all of the given filters.+class AutoFiltersOpsDesc (filters :: [Type -> Type]) where+    autoFiltersOpsDesc :: OpsDescriptions++instance AutoFiltersOpsDesc '[] where+    autoFiltersOpsDesc = mempty++instance ( IsAutoFilter filter+         , AutoFiltersOpsDesc filters+         ) =>+         AutoFiltersOpsDesc (filter ': filters) where+    autoFiltersOpsDesc = mconcat+        [ autoFilterEnglishOpsNames @filter+        , autoFiltersOpsDesc @filters+        ]++-- | Get documentation for the given filter kind.+class FilterKindHasSwagger (fk :: FilterKind Type) where+    filterKindSwagger :: Text -> S.Param++instance DescribedParam a => FilterKindHasSwagger ('ManualFilter a) where+    filterKindSwagger name = filterSwaggerParam @a name (manualFilterDesc @a)++instance (DescribedParam a, AutoFiltersOpsDesc (SupportedFilters a)) =>+         FilterKindHasSwagger ('AutoFilter a) where+    filterKindSwagger name = filterSwaggerParam @a name (autoFilterDesc @a ops)+      where+        ops = autoFiltersOpsDesc @(SupportedFilters a)++-- | Get documentation for given filtering params.+class FilterParamsHaveSwagger (params :: [TyNamedFilter]) where+    filterParamsSwagger :: [S.Param]++instance FilterParamsHaveSwagger '[] where+    filterParamsSwagger = mempty++instance ( KnownSymbol name, FilterKindHasSwagger fk+         , FilterParamsHaveSwagger params+         ) =>+         FilterParamsHaveSwagger ('TyNamedParam name fk ': params) where+    filterParamsSwagger =+        filterKindSwagger @fk (symbolValT @name) : filterParamsSwagger @params++instance (HasSwagger api, ReifyParamsNames params, FilterParamsHaveSwagger params) =>+         HasSwagger (FilteringParams params :> api) where+    toSwagger _ = toSwagger (Proxy @api)+        & S.allOperations . S.parameters <>~ map S.Inline (filterParamsSwagger @params)

@@ -0,0 +1,423 @@+{-# LANGUAGE PolyKinds #-}++-- | Allows to enable logging of requests and responses.+module Servant.Util.Combinators.Logging+    ( -- * Automatic requests logging+      LoggingApi+    , LoggingApiRec+    , HasLoggingServer (..)+    , ServantLogConfig (..)+    , ForResponseLog (..)+    , buildListForResponse+    , buildForResponse+    , ApiHasArgClass (..)+    , ApiCanLogArg (..)+    , addParamLogInfo+    , setInPrefix+    , serverWithLogging+    ) where++import Universum++import Control.Monad.Error.Class (catchError, throwError)+import Data.Default (Default (..))+import Data.Reflection (Reifies (..), reify)+import Data.Swagger (Swagger)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Fmt (Buildable (..), Builder, blockListF, pretty, (+|), (|+), (||+))+import GHC.IO.Unsafe (unsafePerformIO)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Servant.API (Capture, Description, NoContent, NoContentVerb, QueryFlag, QueryParam', Raw,+                    ReflectMethod (..), ReqBody, SBoolI, Summary, Verb, (:<|>) (..), (:>))+import Servant.API.Modifiers (FoldRequired, foldRequiredArgument)+import Servant.Server (Handler (..), HasServer (..), Server, ServerError (..))+import Servant.Swagger.UI.Core (SwaggerUiHtml)+import System.Console.Pretty (Color (..), Style (..), color, style)++import qualified Data.Text as T+import qualified Servant.Server.Internal as SI++import Servant.Util.Common++-- | Enables logging for server which serves given api.+--+-- `config` is a type at which you have to specify 'ServantLogConfig' via+-- reflection. This way was chosen because the least thing we need in+-- config is 'LoggerName', and we want to have '<>' on 'LoggerName's thus+-- 'KnownSymbol' is not enough.+--+-- This logging will report+--+-- * Request parameters, including request bodies+-- * If execution failed with error, it will be displayed+-- * Details like request method and endpoint execution time+--+-- If user makes request which is not defined it won't be logged. However,+-- I don't find it a great problem, it may impede only in development or on+-- getting acknowledged with api.+data LoggingApi config api++-- | Helper to traverse servant api and apply logging.+data LoggingApiRec config api++newtype ServantLogConfig = ServantLogConfig+    { clcLog :: Text -> IO ()+    }++dullColor :: Color -> Text -> Text+dullColor c = style Faint . color c++gray :: Text -> Text+gray = dullColor White++-- | Used to incrementally collect info about passed parameters.+data ApiParamsLogInfo+      -- | Parameters gathered at current stage.+      -- The first field tells whether have we met '(:<|>)',+      -- the second is path prefix itself,+      -- the third field is the remaining part.+    = ApiParamsLogInfo Bool [Text] [Text]+      -- | Parameters collection failed with reason+      --   (e.g. decoding error)+    | ApiNoParamsLogInfo Text++instance Default ApiParamsLogInfo where+    def = ApiParamsLogInfo False [] []++addParamLogInfo :: Text -> ApiParamsLogInfo -> ApiParamsLogInfo+addParamLogInfo _ failed@ApiNoParamsLogInfo{} = failed+addParamLogInfo paramInfo (ApiParamsLogInfo False path []) =+    ApiParamsLogInfo False (paramInfo : path) []+addParamLogInfo paramInfo (ApiParamsLogInfo inPrefix path infos) =+    ApiParamsLogInfo inPrefix path (paramInfo : infos)++setInPrefix :: ApiParamsLogInfo -> ApiParamsLogInfo+setInPrefix failed@ApiNoParamsLogInfo{}     = failed+setInPrefix infos@(ApiParamsLogInfo _ [] _) = infos+setInPrefix (ApiParamsLogInfo _ path info)  = ApiParamsLogInfo True path info++-- | When it comes to logging responses, returned data may be very large.+-- Log space is valuable (already in testnet we got truncated logs),+-- so we have to care about printing only whose data which may be useful.+newtype ForResponseLog a = ForResponseLog { unForResponseLog :: a }++buildListForResponse+    :: Buildable (ForResponseLog x)+    => (forall a. [a] -> [a]) -> ForResponseLog [x] -> Builder+buildListForResponse truncList (ForResponseLog l) =+    let startNf = if null l then "" else "\n"+        lt = truncList l+        diff = length l - length lt+        mMore | diff == 0 = ""+              | otherwise = "\n    and " +| diff |+ " entries more..."+    in  startNf +| blockListF (map ForResponseLog lt) |+ mMore++buildForResponse :: Buildable a => ForResponseLog a -> Builder+buildForResponse = build . unForResponseLog++instance ( HasServer (LoggingApiRec config api) ctx+         , HasServer api ctx+         ) =>+         HasServer (LoggingApi config api) ctx where+    type ServerT (LoggingApi config api) m = ServerT api m++    route = inRouteServer @(LoggingApiRec config api) route+            (def, )++    hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)++-- | Version of 'HasServer' which is assumed to perform logging.+-- It's helpful because 'ServerT (LoggingApi ...)' is already defined for us+-- in actual 'HasServer' instance once and forever.+class HasServer api ctx => HasLoggingServer config api ctx where+    routeWithLog+        :: Proxy (LoggingApiRec config api)+        -> SI.Context ctx+        -> SI.Delayed env (Server (LoggingApiRec config api))+        -> SI.Router env++instance HasLoggingServer config api ctx =>+         HasServer (LoggingApiRec config api) ctx where+    type ServerT (LoggingApiRec config api) m =+         (ApiParamsLogInfo, ServerT api m)++    route = routeWithLog++    hoistServerWithContext _ pc nt s =+        hoistServerWithContext (Proxy :: Proxy api) pc nt <$> s++instance ( HasLoggingServer config api1 ctx+         , HasLoggingServer config api2 ctx+         ) =>+         HasLoggingServer config (api1 :<|> api2) ctx where+    routeWithLog =+        inRouteServer+            @(LoggingApiRec config api1 :<|> LoggingApiRec config api2)+            route $+            \(paramsInfo, f1 :<|> f2) ->+                let paramsInfo' = setInPrefix paramsInfo+                in (paramsInfo', f1) :<|> (paramsInfo', f2)++instance ( KnownSymbol path+         , HasLoggingServer config res ctx+         ) =>+         HasLoggingServer config (path :> res) ctx where+    routeWithLog =+        inRouteServer @(path :> LoggingApiRec config res) route $+        first updateParamsInfo+      where+        updateParamsInfo =+            let path = toText . symbolVal $ Proxy @path+            in  addParamLogInfo path++-- | Describes a way to log a single parameter.+class ApiHasArgClass subApi =>+      ApiCanLogArg subApi where+    type ApiArgToLog subApi :: Type+    type ApiArgToLog subApi = ApiArg subApi++    toLogParamInfo+        :: Buildable (ApiArgToLog subApi)+        => Proxy subApi -> ApiArg subApi -> Text+    default toLogParamInfo+        :: Buildable (ApiArg subApi)+        => Proxy subApi -> ApiArg subApi -> Text+    toLogParamInfo _ param = pretty param++instance KnownSymbol s => ApiCanLogArg (Capture s a)++instance ApiCanLogArg (ReqBody ct a)++instance ( Buildable a+         , KnownSymbol cs+         , SBoolI (FoldRequired mods)+         ) =>+         ApiCanLogArg (QueryParam' mods cs a) where+    type ApiArgToLog (QueryParam' mods cs a) = a+    toLogParamInfo _ mparam = foldRequiredArgument (Proxy :: Proxy mods) (\(a :: a) -> pretty a)+      (\case+        Just a  -> pretty a+        Nothing -> noEntry) mparam+      where+        noEntry = gray "-"++instance KnownSymbol cs => ApiCanLogArg (QueryFlag cs) where+    type ApiArgToLog (QueryFlag cs) = Bool++paramRouteWithLog+    :: forall config api subApi res ctx env.+       ( api ~ (subApi :> res)+       , HasServer (subApi :> LoggingApiRec config res) ctx+       , ApiHasArg subApi res+       , ApiHasArg subApi (LoggingApiRec config res)+       , ApiCanLogArg subApi+       , Buildable (ApiArgToLog subApi)+       )+    => Proxy (LoggingApiRec config api)+    -> SI.Context ctx+    -> SI.Delayed env (Server (LoggingApiRec config api))+    -> SI.Router env+paramRouteWithLog =+    inRouteServer @(subApi :> LoggingApiRec config res) route $+        \(paramsInfo, f) a -> (a `updateParamsInfo` paramsInfo, f a)+  where+    updateParamsInfo a =+        let paramVal = toLogParamInfo (Proxy @subApi) a+            paramName = apiArgName $ Proxy @subApi+            paramInfo = paramName |+ ": " +| paramVal |+ ""+        in addParamLogInfo paramInfo . setInPrefix++instance ( HasServer (subApi :> res) ctx+         , HasServer (subApi :> LoggingApiRec config res) ctx+         , ApiHasArg subApi res+         , ApiHasArg subApi (LoggingApiRec config res)+         , ApiCanLogArg subApi+         , Buildable (ApiArgToLog subApi)+         , subApi ~ apiType (a :: Type)+         ) =>+         HasLoggingServer config (apiType a :> res) ctx where+    routeWithLog = paramRouteWithLog++instance ( HasLoggingServer config res ctx+         , KnownSymbol s+         ) =>+         HasLoggingServer config (QueryFlag s :> res) ctx where+    routeWithLog = paramRouteWithLog++instance HasLoggingServer config res ctx =>+         HasLoggingServer config (Summary s :> res) ctx where+    routeWithLog = inRouteServer @(Summary s :> LoggingApiRec config res) route id++instance HasLoggingServer config res ctx =>+         HasLoggingServer config (Description d :> res) ctx where+    routeWithLog = inRouteServer @(Description d :> LoggingApiRec config res) route id+++-- | Unique identifier for request-response pair.+newtype RequestId = RequestId Integer++instance Buildable RequestId where+    build (RequestId i) = "#" +| i |+ ""++-- | We want all servant servers to have non-overlapping ids,+-- so using singleton counter here.+requestsCounter :: TVar Integer+requestsCounter = unsafePerformIO $ newTVarIO 0+{-# NOINLINE requestsCounter #-}++nextRequestId :: MonadIO m => m RequestId+nextRequestId = atomically $ do+    modifyTVar' requestsCounter (+1)+    RequestId <$> readTVar requestsCounter++-- | Modify an action so that it performs all the required logging.+applyServantLogging+    :: ( Reifies config ServantLogConfig+       , ReflectMethod (method :: k)+       )+    => Proxy config+    -> Proxy method+    -> ApiParamsLogInfo+    -> (a -> Text)+    -> Handler a+    -> Handler a+applyServantLogging configP methodP paramsInfo showResponse action = do+    timer <- mkTimer+    reqId <- nextRequestId+    catchErrors reqId timer $ do+        reportRequest reqId+        res <- action+        reportResponse reqId timer res+        return res+  where+    method = decodeUtf8 $ reflectMethod methodP :: Text+    cmethod =+        let c = case method of+              "GET"    -> Cyan+              "POST"   -> Yellow+              "PUT"    -> Green+              "DELETE" -> Red+              _        -> Magenta+        in style Faint $ color c method+    mkTimer :: MonadIO m => m (m Text)+    mkTimer = do+        startTime <- liftIO getPOSIXTime+        return $ do+            endTime <- liftIO getPOSIXTime+            return . show $ endTime - startTime+    log :: Text -> Handler ()+    log = liftIO ... clcLog $ reflect configP+    eParamLogs :: Either Text Text+    eParamLogs = case paramsInfo of+        ApiParamsLogInfo _ path infos -> Right $+            let pathPart =+                    "    " <> gray ":>" <> " " <>+                    T.intercalate (gray "/") (reverse path)+                infoPart = reverse infos <&> \info ->+                    "    " +| gray ":>"+                    |+ " " +| info |+ ""+            in T.intercalate "\n" (pathPart : infoPart)+        ApiNoParamsLogInfo why -> Left why+    reportRequest :: RequestId -> Handler ()+    reportRequest reqId =+        case eParamLogs of+            Left e ->+                log $ "\n" +| dullColor Red "Unexecuted request due to error"+                    |+ " " +| e+                    |+ ""+            Right paramLogs -> do+                log $  "\n" +| cmethod+                    |+ " "  +| gray ("Request " <> pretty reqId)+                    |+ "\n" +| paramLogs |+ ""+    responseTag reqId = "Response " <> pretty reqId+    reportResponse reqId timer resp = do+        durationText <- timer+        log $+            "\n    " +| gray (responseTag reqId)+              |+ " " +| (dullColor Green "OK")+              |+ " " +| durationText+              |+ " " +| gray ">"+              |+ " " +| showResponse resp+              |+ ""+    catchErrors reqId st =+        flip catchError (servantErrHandler reqId st) .+        handleAny (exceptionsHandler reqId st)+    servantErrHandler reqId timer err@ServerError{..} = do+        durationText <- timer+        let errMsg = errHTTPCode |+ " "  +| errReasonPhrase |+ ":"+        log $+            "\n    " +| gray (responseTag reqId)+              |+ " " +| durationText+              |+ " " +| dullColor Red errMsg+              |+ " " +| decodeUtf8 @Text errBody+              |+ ""+        throwError err+    exceptionsHandler reqId timer e = do+        durationText <- timer+        log $+            "\n    " +| dullColor Red (responseTag reqId)+              |+ " " +| e+             ||+ " " +| durationText+              |+ ""+        throwM e++applyLoggingToHandler+    :: forall k config method a.+       ( Buildable (ForResponseLog a)+       , Reifies config ServantLogConfig+       , ReflectMethod method+       )+    => Proxy config -> Proxy (method :: k) -> (ApiParamsLogInfo, Handler a) -> Handler a+applyLoggingToHandler configP methodP (paramsInfo, handler) = do+    applyServantLogging configP methodP paramsInfo (pretty . ForResponseLog) handler++skipLogging :: (ApiParamsLogInfo, action) -> action+skipLogging = snd++instance ( HasServer (Verb mt st ct a) ctx+         , Reifies config ServantLogConfig+         , ReflectMethod mt+         , Buildable (ForResponseLog a)+         ) =>+         HasLoggingServer config (Verb (mt :: k) (st :: Nat) (ct :: [Type]) a) ctx where+    routeWithLog =+        inRouteServer @(Verb mt st ct a) route $+        applyLoggingToHandler (Proxy @config) (Proxy @mt)++instance ( HasServer (NoContentVerb mt) ctx+         , Reifies config ServantLogConfig+         , ReflectMethod mt+         ) =>+         HasLoggingServer config (NoContentVerb (mt :: k)) ctx where+    routeWithLog =+        inRouteServer @(NoContentVerb mt) route $+        applyLoggingToHandler (Proxy @config) (Proxy @mt)++instance HasLoggingServer config Raw ctx where+    routeWithLog = inRouteServer @Raw route skipLogging++instance Buildable (ForResponseLog NoContent) where+    build _ = "<no response>"++instance Buildable (ForResponseLog ()) where+    build _ = "<no response>"++instance Buildable (ForResponseLog Integer) where+    build = buildForResponse++instance Buildable (ForResponseLog Swagger) where+    build _ = "Swagger specification"++instance Buildable (ForResponseLog (SwaggerUiHtml dir api)) where+    build _ = "Accessed documentation UI"++-- | Apply logging to the given server.+serverWithLogging+    :: forall api a.+       ServantLogConfig+    -> Proxy api+    -> (forall (config :: Type). Reifies config ServantLogConfig =>+        Proxy (LoggingApi config api) -> a)+    -> a+serverWithLogging config _ f =+    reify config $ \(Proxy :: Proxy config) -> f (Proxy @(LoggingApi config api))

@@ -0,0 +1,184 @@+-- | Provides pagination API combinator.+module Servant.Util.Combinators.Pagination+    ( PaginationParams+    , PaginationPageSize (..)+    , KnownPaginationPageSize+    , PaginationSpec (..)+    , defPageSize+    , itemsOnPage+    , skipping+    , fullContent+    ) where++import Universum++import Control.Lens ((<>~), (?~))+import Data.Default (Default (..))+import qualified Data.Swagger as S+import qualified Data.Text as T+import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, HasServer (..),+                QueryParam, (:>))+import Servant.Client (HasClient (..))+import Servant.Swagger (HasSwagger (..))++import Servant.Server.Internal.Context (type (.++))+import Servant.Util.Combinators.Logging+import Servant.Util.Common+import Servant.Util.Internal.Util++-- | API combinator which enables pagination.+--+-- Pagination parameters are specified via @offset@ and @limit@ query parameters.+-- Both fields are optional; @offset@ defaults to @0@ and default value of @limit@+-- is defined in @settings@ argument.+--+-- Your endpoint implementation will be provided with 'PaginationSpec' variable+-- which will contain parameters provided by the user.+data PaginationParams (settings :: PaginationPageSize)++-- | Determines the page size used when client leaves it unspecified.+data PaginationPageSize+    -- | Use specified default.+    = DefPageSize Nat+    -- | Display all contents.+    | DefUnlimitedPageSize++-- | Contains pagination parameters provided by the user.+data PaginationSpec = PaginationSpec+    { psOffset :: Natural+      -- ^ How many elements to skip.+    , psLimit  :: Maybe (Positive Natural)+      -- ^ Maximum number of elements to leave.+      -- 'Nothing' stands for infinity.+    }++class KnownPaginationPageSize (settings :: PaginationPageSize) where+  settingDefPageSize :: Maybe (Positive Natural)++instance KnownPositive pageSize => KnownPaginationPageSize ('DefPageSize pageSize) where+  settingDefPageSize = Just (positiveVal @pageSize)++instance KnownPaginationPageSize 'DefUnlimitedPageSize where+  settingDefPageSize = Nothing++-- | How servant sees 'PaginationParams' under the hood.+type PaginationParamsExpanded subApi =+    QueryParam "offset" Natural :>+    QueryParam "limit" (Positive Natural) :>+    subApi++instance ( HasServer subApi ctx+         , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters+         , KnownPaginationPageSize settings+         ) => HasServer (PaginationParams settings :> subApi) ctx where+    type ServerT (PaginationParams settings :> subApi) m =+        PaginationSpec -> ServerT subApi m++    route =+        inRouteServer @(PaginationParamsExpanded subApi) route $+        \handler offset limit ->+            handler PaginationSpec+            { psOffset = offset ?: 0+            , psLimit = limit <|> settingDefPageSize @settings+            }++    hoistServerWithContext _ pc nt s =+        hoistServerWithContext (Proxy @subApi) pc nt . s++instance+  ( HasLoggingServer config subApi ctx+  , KnownPaginationPageSize settings+  , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters+  ) =>+  HasLoggingServer config (PaginationParams settings :> subApi) ctx where+    routeWithLog =+        inRouteServer @(PaginationParams settings :> LoggingApiRec config subApi) route $+        \(paramsInfo, handler) pagination@PaginationSpec{..} ->+            let text = merge . catMaybes $+                  [ guard (psOffset > 0) $> ("offset " <> show psOffset)+                  , fmap @Maybe+                      (\limit -> show (unPositive limit) <> " per page")+                      psLimit+                  ]+            in (addParamLogInfo text paramsInfo, handler pagination)+      where+        merge ts+            | null ts = "no pagination"+            | otherwise = T.intercalate ", " ts+++-- | Do not paginate anything, use default page size.+defPageSize :: PaginationSpec+defPageSize = PaginationSpec{ psOffset = 0, psLimit = Nothing }++-- | Conveient builder for 'PaginationRequest', creates pagination+-- with zero offset and given limit.+itemsOnPage :: HasCallStack => Natural -> PaginationSpec+itemsOnPage limit = PaginationSpec+  { psOffset = 0+  , psLimit = Just (unsafeToPositive limit)+  }++-- | Convenient builder for 'PaginationRequest', modifies offset.+skipping :: Natural -> PaginationSpec -> PaginationSpec+skipping offset pagination = pagination{ psOffset = offset }++-- | Do not paginate anything.+fullContent :: PaginationSpec+fullContent = defPageSize+{-# DEPRECATED fullContent "Use `defPageSize` instead" #-}++-- | Retains full content.+instance Default PaginationSpec where+    def = defPageSize++instance HasClient m subApi =>+         HasClient m (PaginationParams settings :> subApi) where+    type Client m (PaginationParams settings :> subApi) =+        PaginationSpec -> Client m subApi++    clientWithRoute mp _ req PaginationSpec{..} =+        clientWithRoute mp (Proxy @(PaginationParamsExpanded subApi)) req+            (guard (psOffset > 0) $> psOffset)+            psLimit++    hoistClientMonad pm _ hst subCli = hoistClientMonad pm (Proxy @subApi) hst . subCli++instance (HasSwagger api, KnownPaginationPageSize settings) =>+         HasSwagger (PaginationParams settings :> api) where+    toSwagger _ = toSwagger (Proxy @api)+        & S.allOperations . S.parameters <>~ [S.Inline offsetParam, S.Inline limitParam]+      where+        offsetParam :: S.Param+        limitParam :: S.Param+        offsetParam = mempty+            & S.name .~ "offset"+            & S.description ?~+                "Pagination parameter. How many items to skip from the beginning."+            & S.required ?~ False+            & S.schema .~ S.ParamOther (mempty+                & S.in_ .~ S.ParamQuery+                & S.paramSchema .~ offsetParamSchema+                )+        offsetParamSchema = mempty+            & S.type_ ?~ S.SwaggerInteger+            & S.format ?~ "int32"++        limitParam = mempty+            & S.name .~ "limit"+            & S.description ?~ mconcat+                [ "Pagination parameter. Maximum number of items to return.\n"+                , defaultPageSizeDesc+                ]+            & S.required ?~ False+            & S.schema .~ S.ParamOther (mempty+                & S.in_ .~ S.ParamQuery+                & S.paramSchema .~ limitParamSchema+                )+        limitParamSchema = mempty+            & S.type_ ?~ S.SwaggerInteger+            & S.format ?~ "int32"+            & S.pattern ?~ "^\\d*[1-9]\\d*$"+        defaultPageSizeDesc = case settingDefPageSize @settings of+          Nothing -> "By default, no limit will be applied."+          Just s  -> "Defaults to " <> show (unPositive s) <> "."

@@ -0,0 +1,32 @@+-- | Provides combinator for lexicographical sorting.+module Servant.Util.Combinators.Sorting+    ( -- * General+      SortingParams+    , SortingSpec+    , SortingOrderType (..)++      -- * Shortcuts+    , SortingParamProvidedOf+    , SortingParamBaseOf+    , SortingParamsOf+    , SortingSpecOf++      -- * Manual construction+    , SortingRequestItem+    , asc, desc+    , mkSortingSpec+    , noSorting+    , ReifySortingItems++      -- * Re-exports+    , type (?:)+    ) where++import Servant.Util.Combinators.Sorting.Arbitrary ()+import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Combinators.Sorting.Client ()+import Servant.Util.Combinators.Sorting.Construction+import Servant.Util.Combinators.Sorting.Logging ()+import Servant.Util.Combinators.Sorting.Server ()+import Servant.Util.Combinators.Sorting.Swagger ()+import Servant.Util.Common

@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Manual construction of sorting spec.+module Servant.Util.Combinators.Sorting.Arbitrary () where++import Universum++import Test.QuickCheck (Arbitrary (..), elements, infiniteList, shuffle, sublistOf)++import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Common+++instance Arbitrary SortingOrder where+    arbitrary = elements [Ascendant, Descendant]++instance (ReifySortingItems base, ReifyParamsNames provided) =>+         Arbitrary (SortingSpec provided base) where+    arbitrary = do+        let names = toList $ reifyParamsNames @provided+        someNames <- sublistOf =<< shuffle names+        orders <- infiniteList+        let sortItems = zipWith SortingItem someNames orders+        return (SortingSpec sortItems)+    shrink SortingSpec{..} = map SortingSpec . reverse $ inits ssProvided

@@ -0,0 +1,102 @@+-- | Applying sorting specifications.+module Servant.Util.Combinators.Sorting.Backend+    ( SortingBackend (..)+    , fieldSort+    , SortingApp (..)+    , SortingSpecApp++    , ApplyToSortItem (..)+    , backendApplySorting+    ) where++import Universum++import GHC.TypeLits (KnownSymbol)++import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Common++-- | Implementation of filtering backend.+class SortingBackend backend where++    -- | The part of object which we are filtering on,+    -- provided by server backend implementor.+    type SortedValue backend a :: *++    -- | What we require from sorted values in order to be sortable.+    type SortedValueConstraint backend a :: Constraint+    type SortedValueConstraint backend a = ()++    -- | A resulting ordering.+    type BackendOrdering backend :: *++    -- | Implement 'SortingApp' as sorting on the given field.+    backendFieldSort+        :: SortedValueConstraint backend a+        => SortedValue backend a+        -> SortingApp backend ('TyNamedParam name a)++fieldSort+    :: forall name a backend.+       (SortingBackend backend, SortedValueConstraint backend a)+    => SortedValue backend a -> SortingApp backend ('TyNamedParam name a)+fieldSort = backendFieldSort++-- | A function defining a way to apply the given 'SortingItem' (which is sorting+-- order on a single parameter).+newtype SortingApp backend param+    = SortingApp (SortingItemTagged param -> BackendOrdering backend)++{- | List of 'SortingApp' functions. Describes how to apply @SortingSpec params@+(each of possible 'SortingItem') to an SQL query.++Instance of this type can be created using 'fieldSort' function. For example:++@+sortingSpecApp :: SortingSpecApp ["course" ?: Course, "desc" ?: Text]+sortingSpecApp =+    fieldSort @"course" courseField .*.+    fieldSort @"desc" descField .*.+    HNil+@++Annotating 'fieldSort' call with parameter name is not mandatory but recommended+to prevent possible mistakes in 'fieldSort's ordering.+-}+type SortingSpecApp backend (allParams :: [TyNamedParam *]) =+    HList (SortingApp backend) allParams++-- | Lookup for appropriate 'SortingApp' in 'SortingSpecApp' and apply it to 'SortingItem'.+class ApplyToSortItem backend params where+    -- | Apply spec app to the given 'SortingItem'+    -- We return 'Maybe' here (instead of forcing presence at type-level) for convenience.+    applyToSortItem+        :: SortingSpecApp backend params+        -> SortingItem+        -> Maybe (BackendOrdering backend)++instance ApplyToSortItem backend '[] where+    applyToSortItem HNil _ = Nothing++instance (KnownSymbol name, ApplyToSortItem backend params) =>+         ApplyToSortItem backend ('TyNamedParam name p ': params) where+    applyToSortItem (SortingApp app `HCons` appRem) item = asum+        [ guard (symbolValT @name == siName item) $> app (SortingItemTagged item)+        , applyToSortItem @backend @params appRem item+        ]++-- | Apply a given 'SortingSpecApp' to a 'SortingSpec' producing a pack of+-- ordering values which define lexicographical sorting order.+backendApplySorting+    :: forall provided base allParams backend.+       ( allParams ~ AllSortingParams provided base+       , ApplyToSortItem backend allParams+       )+    => SortingSpec provided base+    -> SortingSpecApp backend allParams+    -> [BackendOrdering backend]+backendApplySorting spec app =+    ssAll spec <&> \sitem ->+        applyToSortItem @backend @allParams app sitem+           -- impossible due to invariants of 'SortingSpec'+        ?: error ("Impossible: don't know how to apply to spec item " <> show sitem)

@@ -0,0 +1,223 @@+module Servant.Util.Combinators.Sorting.Base+    ( SortingParams+    , SortParamsExpanded+    , SortingSpec (..)+    , ssBase+    , ssAll+    , SortingOrder (..)+    , NullsSortingOrder (..)+    , SortingItemTagged (..)+    , SortingItem (..)+    , TaggedSortingItemsList+    , SortingOrderType (..)+    , ReifySortingItems (..)+    , BaseSortingToParam+    , AllSortingParams+    , SortingParamProvidedOf+    , SortingParamBaseOf+    , SortingParamsOf+    , SortingSpecOf+    ) where++import Universum++import Data.List (nubBy)+import Fmt (Buildable (..))+import GHC.TypeLits (KnownSymbol)+import Servant (QueryParam, (:>))+import Servant.API (NoContent)+import Servant.Server (Tagged (..))+import Servant.Util.Common+import qualified Text.Show++{- | Servant API combinator which allows to accept sorting parameters as a query parameter.++Example: with the following combinator++@+SortingParams ["time" ?: Timestamp, "name" ?: Text] '[]+@++the endpoint can parse "sortBy=-time,+name" or "sortBy=desc(time),asc(name)" formats,+which would mean sorting by mentioned fields lexicographically. All sorting+subparameters are optional, as well as entire "sortBy" parameter.++The second type-level list stands for the base sorting order, it will be applied+in the end disregard the user's input.+It is highly recommended to specify the base sorting that unambigously orders the+result(for example - by the primary key of the database), otherwise pagination+may behave unexpectedly for the client when it specifies no sorting.++If you want the base sorting order to be overridable by the user, you can+put the respective fields in both lists. For example, this combinator:++@+SortingParams+  '["time" ?: Timestamp]+   ["id" ?: '(Id, 'Descendant), "time" ?: '(Timestamp, 'Ascendant)]+@++will sort results lexicographically by @(Down id, time)@, but if the client+specifies sorting by time, you will get sorting by @(time, Down id)@ as the+trailing @"time"@ will not affect anything.++It is preferred to put a base sorting at least by @ID@, this way results will be+more deterministic.++Your handler will be provided with 'SortingSpec' argument which can later be passed+in an appropriate function to perform sorting.+-}+data SortingParams+  (provided :: [TyNamedParam *])+  (base :: [TyNamedParam (SortingOrderType *)])++-- | How servant sees 'SortParams' under the hood.+type SortParamsExpanded allowed subApi =+    QueryParam "sortBy" (TaggedSortingItemsList allowed) :> subApi++-- | Order of sorting.+data SortingOrder+    = Descendant+    | Ascendant+    deriving (Show, Eq, Enum)++-- | Where to place null fields.+data NullsSortingOrder+    = NullsFirst+    | NullsLast+    deriving (Show, Eq, Enum)++-- | For a given field, user-supplied order of sorting.+-- This type is primarly for internal use, see also 'SortingItemTagged'.+data SortingItem = SortingItem+    { siName  :: Text+      -- ^ Name of parameter.+      -- Always matches one in @param@, but we keep it at term-level as well for convenience.+    , siOrder :: SortingOrder+      -- ^ Sorting order on the given parameter.++    -- , siNullsOrder :: Maybe NullsSortingOrder+      ---- ^ Order of null fields.+      ---- Present only when the second element in @param@ tuple is 'Maybe'.+      ---- TODO [DSCP-425] add support for this+    } deriving (Show)++-- | Version 'SortingItem' which remembers its name and parameter type at type level.+-- In functions which belong to public API you will most probably want to use this datatype+-- as a safer variant of 'SortingItem'.+newtype SortingItemTagged (provided :: TyNamedParam *) = SortingItemTagged+    { untagSortingItem :: SortingItem+    } deriving (Show)++instance Buildable SortingItem where+    build SortingItem{..} =+        let order = case siOrder of { Ascendant -> "⯅ "; Descendant -> "⯆ " }+        in order <> build siName++deriving instance Buildable (SortingItemTagged param)++-- | Tagged, because we want to retain list of allowed fields for parsing+-- (in @instance FromHttpApiData@).+type TaggedSortingItemsList provided = Tagged (provided :: [TyNamedParam *]) [SortingItem]++-- | Order of sorting for type-level.+--+-- Its constructors accept the type of thing we order by, e.g. @Asc Id@.+data SortingOrderType k+    = Desc k+    | Asc k++-- | What is passed to an endpoint, contains all sorting parameters provided by a user.+{- Following properties hold:+1. Each entry in the underlying list has a unique name ('siName' field).+2. Entries correspond to @params@ type, i.e. any 'SortingItem' entry of the underlying+list with name "N" will be present in @params@.++Not all parameters specified by @params@ phantom type can be present, e.g. the underlying+list will be empty if user didn't pass "sortBy" query parameter at all. However,+entries from the base sorting are always present.+-}+data SortingSpec+  (provided :: [TyNamedParam *])+  (base :: [TyNamedParam (SortingOrderType *)]) =+    ReifySortingItems base =>+    SortingSpec+    { ssProvided :: [SortingItem]+      -- ^ Sorting items provided by the user (lexicographical order).+    }++instance Show (SortingSpec provided base) where+    show s =+        "SortingSpec {ssProvided = " <> show (ssProvided s) <>+                   ", ssBase = " <> show (ssBase s) <> "}"++-- | Base sorting items, that are present disregard the client's input+-- (lexicographical order).+--+-- This is a sort of virtual field, so such naming.+ssBase :: forall base provided. SortingSpec provided base -> [SortingItem]+ssBase SortingSpec{} = reifySortingItems @base++-- | Requires given type-level items to be valid specification of sorting.+class ReifySortingItems (items :: [TyNamedParam (SortingOrderType *)]) where+    reifySortingItems :: [SortingItem]++instance ReifySortingItems '[] where+    reifySortingItems = []++instance ( ReifySortingOrder order, KnownSymbol name+         , ReifySortingItems items+         ) => ReifySortingItems ('TyNamedParam name (order field) ': items) where+    reifySortingItems =+        SortingItem+        { siName = symbolValT @name+        , siOrder = reifySortingOrder @order+        } : reifySortingItems @items++class ReifySortingOrder (order :: * -> SortingOrderType *) where+    reifySortingOrder :: SortingOrder++instance ReifySortingOrder 'Asc where+    reifySortingOrder = Ascendant++instance ReifySortingOrder 'Desc where+    reifySortingOrder = Descendant++-- | All sorting items with duplicates removed (lexicographical order).+ssAll :: SortingSpec provided base -> [SortingItem]+ssAll s = nubBy ((==) `on` siName) (ssProvided s <> ssBase s)++-- | Maps @base@ params to the form common for @provided@ and @base@.+type family BaseSortingToParam (base :: [TyNamedParam (SortingOrderType *)])+  :: [TyNamedParam *] where+    BaseSortingToParam '[] = '[]+    BaseSortingToParam ('TyNamedParam name (order field) ': xs) =+      'TyNamedParam name field ': BaseSortingToParam xs++-- | All sorting params, provided + base.+--+-- This does not yet remove duplicates from @provided@ and @base@ sets,+-- we wait for specific use cases to decide how to handle this better.+type family AllSortingParams+  (provided :: [TyNamedParam *])+  (base :: [TyNamedParam (SortingOrderType *)])+  :: [TyNamedParam *] where+    AllSortingParams provided base = provided ++ BaseSortingToParam base++-- | For a given return type of an endpoint get corresponding sorting params+-- that can be specified by user.+-- This mapping is sensible, since we usually allow to sort only on fields appearing in+-- endpoint's response.+type family SortingParamProvidedOf a :: [TyNamedParam *]++-- | For a given return type of an endpoint get corresponding base sorting params.+type family SortingParamBaseOf a :: [TyNamedParam (SortingOrderType *)]++-- | This you will most probably want to specify in API.+type SortingParamsOf a = SortingParams (SortingParamProvidedOf a) (SortingParamBaseOf a)++-- | This you will most probably want to specify in an endpoint implementation.+type SortingSpecOf a = SortingSpec (SortingParamProvidedOf a) (SortingParamBaseOf a)++type instance SortingParamBaseOf NoContent = '[]+type instance SortingParamProvidedOf NoContent = '[]

@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Sorting.Client () where++import Universum++import qualified Data.Text as T+import Servant.API (ToHttpApiData (..), (:>))+import Servant.Client.Core (Client, HasClient (..))+import Servant.Server (Tagged (..))++import Servant.Util.Combinators.Sorting.Base+++instance HasClient m subApi =>+         HasClient m (SortingParams provided base :> subApi) where+    type Client m (SortingParams provided base :> subApi) =+        SortingSpec provided base -> Client m subApi+    clientWithRoute mp _ req (SortingSpec sorting) =+        clientWithRoute mp (Proxy @(SortParamsExpanded provided subApi)) req+            (Just $ Tagged sorting)+    hoistClientMonad mp _ hst subCli = hoistClientMonad mp (Proxy @subApi) hst . subCli++instance ToHttpApiData (TaggedSortingItemsList provided) where+    toUrlPiece (Tagged sorting) =+        T.intercalate "," $ sorting <&> \SortingItem{..} ->+             let order = case siOrder of+                     Ascendant  -> "asc"+                     Descendant -> "desc"+             in order <> "(" <> siName <> ")"

@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Manual construction of sorting spec.+module Servant.Util.Combinators.Sorting.Construction+    ( SortingRequestItem+    , asc, desc+    , mkSortingSpec+    , noSorting+    ) where++import Universum++import Data.Default (Default (..))+import GHC.Exts (IsList (..))+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)++import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Common+++-- | Helper for defining custom 'SortingSpec's,+-- contains 'SortingItem' corresponding to one of parameter in @provided@ list.+newtype SortingRequestItem (provided :: [TyNamedParam *]) = SortingRequestItem+    { unSortingRequestItem :: SortingItem+    } deriving (Show)++type family KnownTypeName+    (origProvided :: [TyNamedParam *])+    (name :: Symbol)+    (provided :: [TyNamedParam *])+        :: Constraint where+    KnownTypeName orig name '[] =+        TypeError ('Text "Parameter " ':<>: 'ShowType name ':<>: 'Text " is not allowed here"+                   ':$$: 'Text "Available fields to sort on: " ':<>:+                         'ShowType (TyNamedParamsNames orig))+    KnownTypeName _ name ('TyNamedParam name _ ': _) = (KnownSymbol name)+    KnownTypeName orig name ('TyNamedParam name0 _ ': provided) = KnownTypeName orig name provided++-- | Ascendant sorting on a field with given name.+asc+    :: forall name provided.+       (KnownSymbol name, KnownTypeName provided name provided)+    => NameLabel name -> SortingRequestItem provided+asc _ = SortingRequestItem SortingItem+      { siName = symbolValT @name+      , siOrder = Ascendant+      }++-- | Ascendant sorting on a field with given name.+desc+    :: forall name provided.+       (KnownSymbol name, KnownTypeName provided name provided)+    => NameLabel name -> SortingRequestItem provided+desc _ = SortingRequestItem SortingItem+      { siName = symbolValT @name+      , siOrder = Descendant+      }++-- | Instance for 'SortingSpec' construction.+instance ReifySortingItems base => IsList (SortingSpec provided base) where+    type Item (SortingSpec provided base) = SortingRequestItem provided+    toList = map SortingRequestItem . ssProvided+    fromList = SortingSpec . map unSortingRequestItem++{- | Make a sorting specification.+Specified list should contain sorting on distinct fields; we do not enforce this+at type-level for convenience.++Example:++@+-- {-# LANGUAGE OverloadedLabels #-}++sortingSpec :: SortingSpec ["id" ?: Int, "desc" ?: Text]+sortingSpec = mkSortingSpec [asc #id]+@++-}+mkSortingSpec+    :: ReifySortingItems base+    => [SortingRequestItem provided] -> SortingSpec provided base+mkSortingSpec = fromList++-- | By default 'noSorting' is used.+instance ReifySortingItems base => Default (SortingSpec provided base) where+    def = noSorting++-- | Do not specify ordering.+noSorting :: ReifySortingItems base => SortingSpec provided base+noSorting = mkSortingSpec []

@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Sorting.Logging () where++import Universum++import qualified Data.List as L+import Fmt (Buildable (..), fmt)+import Servant.API ((:>))+import Servant.Server (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, HasServer (..))++import Servant.Server.Internal.Context (type (.++))+import Servant.Util.Combinators.Logging+import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Combinators.Sorting.Server ()+import Servant.Util.Common++instance ( HasLoggingServer config subApi ctx+         , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters+         , ReifySortingItems base+         , ReifyParamsNames provided+         ) =>+         HasLoggingServer config (SortingParams provided base :> subApi) ctx where+    routeWithLog =+        inRouteServer @(SortingParams provided base :> LoggingApiRec config subApi) route $+        \(paramsInfo, handler) sorting@(SortingSpec provided) ->+            let paramLog+                  | null provided = "no sorting"+                  | otherwise = fmt . mconcat $+                                "sorting: " : L.intersperse " " (map build provided)+            in (addParamLogInfo paramLog paramsInfo, handler sorting)

@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Combinators.Sorting.Server () where++import Universum++import Data.Char (isAlphaNum)+import qualified Data.List as L+import qualified Data.Set as S+import Servant.API (FromHttpApiData (..), (:>))+import Servant.Server (DefaultErrorFormatters, ErrorFormatters, HasServer (..), Tagged (..),+                       unTagged)+import Servant.Server.Internal.Context (HasContextEntry, type (.++))+import Text.Megaparsec ((<?>))+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P++import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Common+++-- | Ensure no name in entries repeat.+sortingCheckDuplicates :: [SortingItem] -> Either Text ()+sortingCheckDuplicates items =+    let names = map siName items+        duplicate = safeHead . mapMaybe (safeHead . drop 1) . L.group $ sort names+    in maybe pass (\n -> Left $ "Duplicated field " <> show n) duplicate++-- | Consumes "sortBy" query parameter and fetches sorting parameters contained in it.+instance ( HasServer subApi ctx+         , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters+         , ReifySortingItems base+         , ReifyParamsNames provided+         ) =>+         HasServer (SortingParams provided base :> subApi) ctx where+    type ServerT (SortingParams provided base :> subApi) m =+        SortingSpec provided base -> ServerT subApi m++    route =+        inRouteServer @(SortParamsExpanded provided subApi) route $+        \handler rawSortItems -> handler (SortingSpec $ fmap unTagged rawSortItems ?: [])++    hoistServerWithContext _ pc nt s =+        hoistServerWithContext (Proxy @subApi) pc nt . s++-- | Parse 'sort_by' query param.+-- Following the format described in "Sorting" section of https://www.moesif.com/blog/technical/api-design/REST-API-Design-Filtering-Sorting-and-Pagination/+instance ReifyParamsNames allowed =>+         FromHttpApiData (TaggedSortingItemsList allowed) where+    parseUrlPiece =+        first (toText . P.errorBundlePretty) . second Tagged .+        P.parse parser "sortBy"+      where+        parser = do+            items <- P.sepBy itemParser (P.char ',')+            either (fail . toString) pure $ sortingCheckDuplicates items+            P.eof+            return items++        itemParser :: P.Parsec Void Text SortingItem+        itemParser = asum+            [ do+                siOrder <- asum+                    [ Ascendant <$ P.char '+'+                    , Descendant <$ P.char '-'+                    ] <?> "ordering sign (+/-)"+                siName <- paramNameParser+                return SortingItem{..}++            , do+                siOrder <- asum+                    [ Ascendant <$ P.string' "asc"+                    , Descendant <$ P.string' "desc"+                    ] <?> "ordering keyword (asc/desc)"+                siName <- P.char '(' *> paramNameParser <* P.char ')'+                return SortingItem{..}+            ]++        allowedParams = reifyParamsNamesSet @allowed++        paramNameParser = do+            name <- P.takeWhile1P (Just "sorting item name") isAlphaNum <?> "parameter name"+            unless (name `S.member` allowedParams) $+                fail $ "unknown parameter " <> show name <>+                       " (expected one of " <> show (toList allowedParams) <> ")"+            return name

@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BlockArguments #-}++module Servant.Util.Combinators.Sorting.Swagger () where++import Universum++import Control.Lens ((<>~), (?~))+import qualified Data.Swagger as S+import qualified Data.Text as T+import Fmt (build, fmt, unlinesF)+import Servant.API ((:>))+import Servant.Swagger (HasSwagger (..))++import Servant.Util.Combinators.Sorting.Base+import Servant.Util.Common++instance (HasSwagger api, ReifySortingItems base, ReifyParamsNames provided) =>+         HasSwagger (SortingParams provided base :> api) where+    toSwagger _ = toSwagger (Proxy @api)+        & S.allOperations . S.parameters <>~ [S.Inline param]+      where+        param = mempty+            & S.name .~ "sortBy"+            & S.description ?~ fmt do+              unlinesF+                [ "Allows lexicographical sorting on fields."+                , "General format is one of:"+                , "  * `+field1,-field2`"+                , "  * `asc(field1),desc(field2)`"+                , ""+                , allowedFieldsDesc+                , baseFieldsDesc+                , " "+                ]+            & S.required ?~ False+            & S.schema .~ S.ParamOther (mempty+                & S.in_ .~ S.ParamQuery+                & S.paramSchema .~ paramSchema+                )+        paramSchema = mempty+            & S.type_ ?~ S.SwaggerString+            & S.pattern ?~ "^" <> fieldPattern <> "(," <> fieldPattern <> ")*" <> "$"+        fieldPattern =+            "(" <> "[+-](" <> allowedFieldsPattern <> ")+" <> "|" <>+            "(asc|desc)\\((" <> allowedFieldsPattern <> ")+\\))"+        allowedFields = reifyParamsNames @provided+        allowedFieldsDesc = mconcat+            [ " Fields allowed for this endpoint: "+            , mconcat . intersperse ", " $+                  map ((<> "`") . ("`" <>) . build) allowedFields+            ]+        allowedFieldsPattern = T.intercalate "|" allowedFields+        baseFields = reifySortingItems @base+        baseFieldsDesc+            | null baseFields = ""+            | otherwise = mconcat+                [ " Base sorting (always applied, lexicographically last): "+                , "`"+                , mconcat . intersperse ", " $ map build baseFields+                , "`"+                ]

@@ -0,0 +1,127 @@+module Servant.Util.Combinators.Tag+    ( Tag+    , TagDescriptions+    , TagsVerification (..)+    ) where++import Universum++import Control.Lens (at, (?~))+import qualified Data.HashSet.InsOrd as HS+import qualified Data.Swagger as S+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)+import Servant (HasServer (..), StdMethod, Verb, (:<|>), (:>))+import Servant.Client (HasClient (..))+import Servant.Swagger (HasSwagger (..))++import Servant.Util.Combinators.Logging+import Servant.Util.Common++-- | Attaches a tag to swagger documentation.+-- Server implementation remains intact.+data Tag (name :: Symbol)++instance HasServer subApi ctx => HasServer (Tag name :> subApi) ctx where+    type ServerT (Tag name :> subApi) m = ServerT subApi m+    route _ = route (Proxy @subApi)+    hoistServerWithContext _ = hoistServerWithContext (Proxy @subApi)++instance HasClient m subApi => HasClient m (Tag name :> subApi) where+    type Client m (Tag name :> subApi) = Client m subApi+    clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi)+    hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst++instance HasLoggingServer config subApi ctx =>+         HasLoggingServer config (Tag name :> subApi) ctx where+    routeWithLog = inRouteServer @(Tag name :> LoggingApiRec config subApi) route id++instance (HasSwagger subApi, KnownSymbol name) =>+         HasSwagger (Tag name :> subApi) where+    toSwagger _ = toSwagger (Proxy @subApi)+        & S.allOperations . S.tags . at name ?~ ()+      where+        name = symbolValT @name++-- | Whether to enable some type-level checks for 'Tag's and 'TagsDescription's+-- correspondence.+data TagsVerification+    = -- | Ensure that mappings are specified exactly for those tags which+      -- appear in API.+      -- This may slow down compilation dramatically starting from ~15 tags.+      VerifyTags+      -- | Do not check anything.+    | NoVerifyTags++-- | Attaches descriptions to tags according to the given+-- @name -> description@ mapping.+-- Unused elements of mapping will cause a compile error; tags which have+-- no mapping declared are not allowed as well.+data TagDescriptions (verify :: TagsVerification) (mapping :: [TyNamedParam Symbol])++instance HasServer subApi ctx => HasServer (TagDescriptions ver mapping :> subApi) ctx where+    type ServerT (TagDescriptions ver mapping :> subApi) m = ServerT subApi m+    route _ = route (Proxy @subApi)+    hoistServerWithContext _ = hoistServerWithContext (Proxy @subApi)++instance HasClient m subApi => HasClient m (TagDescriptions ver mapping :> subApi) where+    type Client m (TagDescriptions ver mapping :> subApi) = Client m subApi+    clientWithRoute pm _ = clientWithRoute pm (Proxy @subApi)+    hoistClientMonad pm _ hst = hoistClientMonad pm (Proxy @subApi) hst++instance HasLoggingServer config subApi ctx =>+         HasLoggingServer config (TagDescriptions ver mapping :> subApi) ctx where+    routeWithLog =+        inRouteServer @(TagDescriptions ver mapping :> LoggingApiRec config subApi)+        route id++-- | Gather all tag names used in API. Result may contain duplicates.+type family AllApiTags api :: [Symbol] where+    AllApiTags (Tag name :> api) = name `InsSorted` AllApiTags api+    AllApiTags (arg :> api) = AllApiTags api+    AllApiTags ((path :: Symbol) :> api) = AllApiTags api+    AllApiTags (api1 :<|> api2) = AllApiTags api1 `UnionSorted` AllApiTags api2+    AllApiTags (Verb (method :: StdMethod) (code :: Nat) ctx a) = '[]++-- | Extract tags defined by this mapping.+class ReifyTagsFromMapping (mapping :: [TyNamedParam Symbol]) where+    reifyTagsFromMapping :: HS.InsOrdHashSet S.Tag++instance ReifyTagsFromMapping '[] where+    reifyTagsFromMapping = mempty++instance ( KnownSymbol name, KnownSymbol desc+         , ReifyTagsFromMapping mapping+         , ParamsContainNoName mapping name+         ) =>+         ReifyTagsFromMapping ('TyNamedParam name desc ': mapping) where+    reifyTagsFromMapping =+        S.Tag+        { S._tagName = symbolValT @name+        , S._tagDescription = Just $ symbolValT @desc+        , S._tagExternalDocs = Nothing+        } `HS.insert` reifyTagsFromMapping @mapping++instance ( HasSwagger api+         , ReifyTagsFromMapping mapping+         ) =>+         HasSwagger (TagDescriptions 'NoVerifyTags mapping :> api) where+    toSwagger _ = toSwagger (Proxy @api)+        & S.tags .~ reifyTagsFromMapping @mapping++instance ( HasSwagger api+         , ReifyTagsFromMapping mapping+         , missingMapping ~ (AllApiTags api // TyNamedParamsNames mapping)+         , If (missingMapping == '[])+            (() :: Constraint)+            (TypeError ('Text "Following tags have no mapping specified in \+                        \TagDescriptions: " ':<>: 'ShowType missingMapping))+         , extraMapping ~ (TyNamedParamsNames mapping // AllApiTags api)+         , If (extraMapping == '[])+            (() :: Constraint)+            (TypeError ('Text "Mappings for the following names specified in \+                              \TagDescriptions are unused: "+                        ':<>: 'ShowType extraMapping))+         ) =>+         HasSwagger (TagDescriptions 'VerifyTags mapping :> api) where+    toSwagger _ = toSwagger (Proxy @api)+        & S.tags .~ reifyTagsFromMapping @mapping

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF autoexporter -Wno-dodgy-exports -Wno-unused-imports #-}

@@ -0,0 +1,85 @@+module Servant.Util.Common.Common+    ( ApplicationLS+    , ApplicationRS+    , ApiHasArgClass (..)+    , ApiHasArg++    , inRouteServer+    , symbolValT++    , NameLabel (..)+    ) where++import Universum++import qualified Data.Text.Buildable as B+import Fmt (pretty)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Servant.API (Capture, QueryFlag, QueryParam', ReqBody, (:>))+import Servant.API.Modifiers (RequiredArgument)+import Servant.Server (Handler (..), HasServer (..), Server)+import qualified Servant.Server.Internal as SI++type family ApplicationLS x where+    ApplicationLS (a b) = a++-- | Extract right side of type application.+type family ApplicationRS x where+    ApplicationRS (a b) = b++-- | Proves info about argument specifier of servant API.+class ApiHasArgClass api where+    -- | For arguments-specifiers of API, get argument type.+    -- E.g. @Capture "cap" Int@ -> @Int@.+    type ApiArg api :: Type+    type ApiArg api = ApplicationRS api++    -- | Name of argument.+    -- E.g. name of argument specified by @Capture "nyan"@ is /nyan/.+    apiArgName+        :: Proxy api -> String+    default apiArgName+        :: forall n someApiType a. (KnownSymbol n, api ~ someApiType n a)+        => Proxy api -> String+    apiArgName _ =+        pretty $ "'" <> B.build (symbolVal $ Proxy @n) <> "' field"++class ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)+   => ApiHasArgInvariant subApi res m+instance ServerT (subApi :> res) m ~ (ApiArg subApi -> ServerT res m)+      => ApiHasArgInvariant subApi res m++type ApiHasArg subApi res =+    ( ApiHasArgClass subApi+    , ApiHasArgInvariant subApi res Handler+    )++instance KnownSymbol s => ApiHasArgClass (Capture s a)+instance KnownSymbol s => ApiHasArgClass (QueryParam' mods s a) where+    type ApiArg (QueryParam' mods s a) = RequiredArgument mods a+instance KnownSymbol s => ApiHasArgClass (QueryFlag s) where+    type ApiArg (QueryFlag s) = Bool+    apiArgName _ =+        pretty $ "'" <> B.build (symbolVal (Proxy @s)) <>  "' flag"+instance ApiHasArgClass (ReqBody ct a) where+    apiArgName _ = "request body"++-- | Modify handler in implementation of 'route'.+inRouteServer+    :: forall api api' ctx env.+       (Proxy api -> SI.Context ctx -> SI.Delayed env (Server api) -> SI.Router env)+    -> (Server api' -> Server api)+    -> (Proxy api' -> SI.Context ctx -> SI.Delayed env (Server api') -> SI.Router env)+inRouteServer routing f = \_ ctx delayed -> routing Proxy ctx (fmap f delayed)++-- | Similar to 'symbolVal', but shorter in use.+symbolValT :: forall s. KnownSymbol s => Text+symbolValT = fromString $ symbolVal (Proxy @s)++-- | Helper for passing type-level symbol at term-level.+-- We do not use 'Proxy' for this because defining+-- @instance IsLabel name (Proxy name)@ in a library is not a really good idea.+data NameLabel (name :: Symbol) = NameLabel++instance (n1 ~ n2) => IsLabel n1 (NameLabel n2) where+    fromLabel = NameLabel

@@ -0,0 +1,64 @@+{-# LANGUAGE PolyKinds #-}++module Servant.Util.Common.HList where++import Data.Kind (Type)+++-- TODO: move to vinyl one day.++-- | Servant package defines their own 'HList', so we also can (to avoid a large dependency).+data HList (f :: k -> Type) (l :: [k]) where+    HNil :: HList f '[]+    HCons :: f a -> HList f as -> HList f (a ': as)+infixr 3 `HCons`++(.*.) :: forall k (f :: k -> Type) (a :: k) (as :: [k]).+         f a -> HList f as -> HList f (a : as)+(.*.) = HCons+infixr 3 .*.+++class HListFromTuple a where+    type HListTuple a :: Type+    htuple :: HListTuple a -> a++instance HListFromTuple (HList f '[]) where+    type HListTuple (HList f '[]) = ()+    htuple () = HNil++instance HListFromTuple (HList f '[a]) where+    type HListTuple (HList f '[a]) = f a+    htuple a = a .*. HNil++instance HListFromTuple (HList f [a, b]) where+    type HListTuple (HList f [a, b]) = (f a, f b)+    htuple (a, b) = a .*. b .*. HNil++instance HListFromTuple (HList f [a, b, c]) where+    type HListTuple (HList f [a, b, c]) = (f a, f b, f c)+    htuple (a, b, c) = a .*. b .*. c .*. HNil++instance HListFromTuple (HList f [a, b, c, d]) where+    type HListTuple (HList f [a, b, c, d]) = (f a, f b, f c, f d)+    htuple (a, b, c, d) = a .*. b .*. c .*. d .*. HNil++instance HListFromTuple (HList f [a, b, c, d, e]) where+    type HListTuple (HList f [a, b, c, d, e]) = (f a, f b, f c, f d, f e)+    htuple (a, b, c, d, e) = a .*. b .*. c .*. d .*. e .*. HNil++instance HListFromTuple (HList f [a, b, c, d, e, g]) where+    type HListTuple (HList f [a, b, c, d, e, g]) = (f a, f b, f c, f d, f e, f g)+    htuple (a, b, c, d, e, g) = a .*. b .*. c .*. d .*. e .*. g .*. HNil++instance HListFromTuple (HList f [a, b, c, d, e, g, h]) where+    type HListTuple (HList f [a, b, c, d, e, g, h]) =+        (f a, f b, f c, f d, f e, f g, f h)+    htuple (a, b, c, d, e, g, h) =+        a .*. b .*. c .*. d .*. e .*. g .*. h .*. HNil++instance HListFromTuple (HList f [a, b, c, d, e, g, h, i]) where+    type HListTuple (HList f [a, b, c, d, e, g, h, i]) =+        (f a, f b, f c, f d, f e, f g, f h, f i)+    htuple (a, b, c, d, e, g, h, i) =+        a .*. b .*. c .*. d .*. e .*. g .*. h .*. i .*. HNil

@@ -0,0 +1,131 @@+{-# LANGUAGE PolyKinds #-}++-- | Everything which requires "PolyKinded" extension, extracted in order+-- not to spoil the remaining code.+module Servant.Util.Common.PolyKinds+    ( TyNamedParam (..)+    , type (?:)+    , TyNamedParamType+    , TyNamedParamsNames+    , ReifyParamsNames (..)+    , reifyParamsNames+    , LookupParam+    , reifyParamsNamesSet+    , ParamsContainNoName+    , Elem+    , If+    , type (==)+    , type (&&)+    , type (||)+    , type (++)+    , type (//)+    , InsSorted+    , UnionSorted+    ) where++import Universum++import qualified Data.Set as S+import GHC.TypeLits (AppendSymbol, CmpSymbol, ErrorMessage (..), KnownSymbol, Symbol, TypeError,+                     symbolVal)+import Servant (If)++-- | Pair of type and its name as it appears in API.+data TyNamedParam a = TyNamedParam Symbol a++-- | Convenient type alias for 'TyNamedParam'.+type (?:) = 'TyNamedParam++type family TyNamedParamType p where+    TyNamedParamType ('TyNamedParam _ a) = a++type family TyNamedParamsNames (params :: [TyNamedParam k]) :: [Symbol] where+    TyNamedParamsNames '[] = '[]+    TyNamedParamsNames ('TyNamedParam name _ ': params) = name ': TyNamedParamsNames params++-- | Extract info from 'SortingParams'.+class ReifyParamsNames (params :: [TyNamedParam k]) where+    -- | Get all expected parameter names.+    reifyParamsNames' :: [Text]++instance ReifyParamsNames '[] where+    reifyParamsNames' = mempty++instance (KnownSymbol name, ReifyParamsNames params, ParamsContainNoName params name) =>+         ReifyParamsNames ('TyNamedParam name (p :: k) ': params) where+    reifyParamsNames' =+        toText (symbolVal @name Proxy) : reifyParamsNames' @k @params++reifyParamsNames :: forall params. ReifyParamsNames params => [Text]+reifyParamsNames = reifyParamsNames' @_ @params++-- | All names are quaranteed to be unique, so taking set of them is safe+-- (number of entires will be preserved).+reifyParamsNamesSet :: forall params. ReifyParamsNames params => Set Text+reifyParamsNamesSet = S.fromList $ reifyParamsNames @params++type family LookupParam (desc :: Symbol) (name :: Symbol)+                        (params :: [TyNamedParam k]) :: k where+    LookupParam desc name '[] =+        TypeError ('Text ("No " `AppendSymbol` desc `AppendSymbol` " with name ")+                   ':<>: 'ShowType name ':<>: 'Text " found")+    LookupParam desc name ('TyNamedParam name a ': params) = a+    LookupParam desc name ('TyNamedParam name0 a ': params) =+        LookupParam desc name params++type family ParamsContainNoName (params :: [TyNamedParam k]) name :: Constraint where+    ParamsContainNoName '[] name = ()+    ParamsContainNoName ('TyNamedParam name p ': params) name =+        TypeError ('Text "Duplicate name in parameters: " ':<>: 'ShowType name)+    ParamsContainNoName ('TyNamedParam name p ': params) name' =+        ParamsContainNoName params name'++-- Some of these can be removed in lts-12+-- (currently base has non-polykinded versions).++type family Elem (a :: k) (l :: [k]) :: Bool where+    Elem a '[]      = 'False+    Elem a (a ': l) = 'True+    Elem a (_ ': l) = Elem a l++type family (==) (a :: k) (b :: k) :: Bool where+    a == a = 'True+    _ == _ = 'False+infix 4 ==++type family (&&) (a :: Bool) (b :: Bool) :: Bool where+    'False && _ = 'False+    _ && 'False = 'False+    'True && 'True = 'True+infix 3 &&++type family (||) (a :: Bool) (b :: Bool) :: Bool where+    'True || _ = 'True+    _ || 'True = 'True+    'False || 'False = 'False+infix 2 ||++type family (++) (as :: [k]) (bs :: [k]) :: [k] where+    '[] ++ bs = bs+    (a ': as) ++ bs = a ': (as ++ bs)++type family (//) (as :: [k]) (bs :: [k]) :: [k] where+    '[] // bs = '[]+    (a ': as) // bs = If (a `Elem` bs) (as // bs) (a ': (as // bs))++type family InsSorted (s :: Symbol) (ss :: [Symbol]) :: [Symbol] where+    InsSorted s '[] = '[s]+    InsSorted s0 (s ': ss) =+        If (CmpSymbol s0 s == 'GT) (s ': InsSorted s0 ss)+          ( If (s0 == s) (s ': ss) (s0 ': s ': ss)+          )++type family UnionSorted (ss1 :: [Symbol]) (ss2 :: [Symbol]) :: [Symbol] where+    UnionSorted ss1 '[] = ss1+    UnionSorted '[] ss2 = ss2+    UnionSorted (s1 ': ss1) (s2 ': ss2) =+        If (s1 == s2) (s1 ': UnionSorted ss1 ss2)+          ( If (CmpSymbol s1 s2 == 'LT)+               (s1 ': UnionSorted ss1 (s2 ': ss2))+               (s2 ': UnionSorted (s1 ': ss1) ss2)+          )

@@ -0,0 +1,2 @@+-- | Contains dummy backend implementations for introduced combinators.+{-# OPTIONS_GHC -F -pgmF autoexporter -Wno-dodgy-exports -Wno-unused-imports #-}

@@ -0,0 +1,105 @@+{- | Implements plain filtering.++Example:++@+filteringSpecApp+    :: MyObject+    -> FilteringSpecApp+        DummyFilteringBackend+        [ "id" ?: 'AutoFilter Course+        , "desc" ?: 'AutoFilter Text+        , "isAwesome" ?: 'ManualFilter Bool+        ]+filteringSpecApp obj =+    filterOn_ @"id" (id obj) .*.+    filterOn_ @"desc" (desc obj) .*.+    customFilter_ @"isAwesome" (== (awesomeness obj > 42)) .*.+    HNil+@++Annotating 'filterOn' and 'customFilter' calls with parameter name is fully optional+and used only to visually disambiguate filters of the same types.++Next, you use `matches` to check whether a value matches user-provided filters.++@+filterObjects filters = filter (matches filters . filteringSpecApp) allObjects+@++-}+module Servant.Util.Dummy.Filtering+    ( matches+    , filterBySpec+    , filterOn+    , manualFilter+    ) where++import Universum++import Data.Bits ((.|.))+import qualified Text.Regex.Posix as R+import qualified Text.Regex.Posix.String as RS++import Servant.Util.Combinators.Filtering.Backend+import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Filters++-- | Implements filters via Beam query expressions ('QExpr').+data DummyFilteringBackend++instance FilterBackend DummyFilteringBackend where+    type AutoFilteredValue DummyFilteringBackend a = a+    type MatchPredicate DummyFilteringBackend = Bool++instance Eq a => AutoFilterSupport DummyFilteringBackend FilterMatching a where+    autoFilterSupport = \case+        FilterMatching v    -> (== v)+        FilterNotMatching v -> (/= v)+        FilterItemsIn vs    -> (`elem` vs)++instance Ord a => AutoFilterSupport DummyFilteringBackend FilterComparing a where+    autoFilterSupport = \case+        FilterGT v  -> (> v)+        FilterLT v  -> (< v)+        FilterGTE v -> (>= v)+        FilterLTE v -> (<= v)++-- | Supported only for trivial cases yet.+instance ToString s => AutoFilterSupport DummyFilteringBackend FilterLike s where+    autoFilterSupport+      (FilterLike (CaseSensitivity cs) (LikePatternUnsafe (toString -> pat))) =+      \(toString -> txt) -> isJust @() $ do+        let compOpts = RS.compBlank+                & if cs then id else (.|. RS.compIgnoreCase)+        -- TODO: report this to servant parser+        regex <- R.makeRegexOptsM compOpts RS.execBlank (transformPat pat)+        R.matchM regex txt+      where+        transformPat s = '^' : replacePatChars s ++ "$"+        replacePatChars = \case+          []      -> []+          '*' : s -> '.' : '*' : replacePatChars s+          c : s   -> c : replacePatChars s++-- | Applies a whole filtering specification to a set of response fields.+-- Resulting value can be put to 'filter' function.+matches+    :: ( backend ~ DummyFilteringBackend+       , BackendApplySomeFilter backend params+       )+    => FilteringSpec params+    -> FilteringSpecApp backend params+    -> Bool+matches = and ... backendApplyFilters++-- | Filters given values by a filtering specification.+filterBySpec+    :: ( backend ~ DummyFilteringBackend+       , BackendApplySomeFilter backend params+       )+    => FilteringSpec params+    -> (a -> FilteringSpecApp backend params)+    -> [a]+    -> [a]+filterBySpec spec mkApp = filter (matches spec . mkApp)

@@ -0,0 +1,13 @@+module Servant.Util.Dummy.Pagination+    ( paginate+    ) where++import qualified Data.List as L+import Universum++import Servant.Util.Combinators.Pagination+import Servant.Util.Internal.Util++paginate :: PaginationSpec -> [a] -> [a]+paginate PaginationSpec{..} =+    maybe id (L.genericTake . unPositive) psLimit . L.genericDrop psOffset

@@ -0,0 +1,77 @@+{- | Implements plain lexicographical sorting.++Example:++@+sortingSpecApp+    :: MyObject+    -> SortingSpecApp+        DummySortingBackend+        [ "id" ?: Int+        , "desc" ?: Text+        ]+sortingSpecApp obj =+    fieldSort @"id" (id obj) .*.+    fieldSort @"desc" (desc obj) .*.+    HNil+@++Next, you use `sortBySpec` to apply sorting.++@+sortObjects sorting = filter (sortBySpec sorting . sortingSpecApp) allObjects+@++-}+module Servant.Util.Dummy.Sorting+    ( SortingSpecApp+    , fieldSort+    , sortBySpec+    ) where++import Universum++import Data.Typeable (cast)++import Servant.Util.Combinators.Sorting.Backend+import Servant.Util.Combinators.Sorting.Base++-- | Implements sorting for beam-postgres package.+data DummySortingBackend++data SomeOrd = forall a. (Typeable a, Ord a) => SomeOrd a++-- | Unsafe instance which assumes that 'SomeOrd' contains the same items inside.+instance Eq SomeOrd where+    (==) = (== EQ) ... compare++-- | Unsafe instance which assumes that 'SomeOrd' contains the same items inside.+instance Ord SomeOrd where+    SomeOrd a `compare` SomeOrd b =+        let b' = cast b ?: error "Compared `SomeOrd`s are different inside"+        in a `compare` b'++instance SortingBackend DummySortingBackend where+    type SortedValue DummySortingBackend a = a+    type BackendOrdering DummySortingBackend = SomeOrd++    type SortedValueConstraint DummySortingBackend a = (Typeable a, Ord a)++    backendFieldSort field = SortingApp $ \(SortingItemTagged (SortingItem _name order)) ->+        case order of+            Ascendant  -> SomeOrd field+            Descendant -> SomeOrd (Down field)++-- | Applies a whole filtering specification to a set of response fields.+-- Resulting value can be put to 'filter' function.+sortBySpec+    :: ( backend ~ DummySortingBackend+       , allParams ~ AllSortingParams provided base+       , ApplyToSortItem backend allParams+       )+    => SortingSpec provided base+    -> (a -> SortingSpecApp backend allParams)+    -> [a] -> [a]+sortBySpec spec mkApp values =+    map fst . sortOn snd $+    map (id &&& backendApplySorting spec . mkApp) values

@@ -0,0 +1,24 @@+-- | Errors in servant.+module Servant.Util.Error+    ( SimpleJSON+    ) where++import Universum++import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)+import Data.Reflection (Reifies (..), reflect)+import Servant (JSON)+import Servant.API.ContentTypes (Accept (..), MimeRender (..), MimeUnrender (..))++-- | Custom json marker which sends no human-unreadable decoding errors+-- but a given fixed one.+data SimpleJSON err++instance Accept (SimpleJSON err) where+    contentTypes _ = contentTypes (Proxy @JSON)+instance ToJSON a => MimeRender (SimpleJSON err) a where+    mimeRender _ = encode+instance (FromJSON a, Reifies err String) => MimeUnrender (SimpleJSON err) a where+    mimeUnrender _ =+        let errMsg = reflect (Proxy @err)+        in first (\_ -> errMsg) . eitherDecode

@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Util.Internal.Util+    ( Positive (..)+    , toPositive+    , unsafeToPositive+    , IsNotZero+    , KnownPositive+    , positiveVal+    ) where++import Universum++import Fmt (Buildable (..))+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Servant (FromHttpApiData (..), ToHttpApiData (..))++newtype Positive a = PositiveUnsafe { unPositive :: a }+    deriving (Show, Eq, Ord)++instance Buildable x => Buildable (Positive x) where+    build = build . unPositive++toPositive :: (Show a, Ord a, Num a) => a -> Either Text (Positive a)+toPositive a+    | a > 0 = Right $ PositiveUnsafe a+    | otherwise = Left $ "Non-positive value: " <> show a++unsafeToPositive :: (Show a, Ord a, Num a, HasCallStack) => a -> Positive a+unsafeToPositive = either error id . toPositive++type family IsNotZero (k :: Nat) :: Constraint where+    IsNotZero 0 = TypeError ('Text "Null is now allowed here")+    IsNotZero k = ()++type KnownPositive k = (KnownNat k, IsNotZero k)++positiveVal :: forall k i. (KnownPositive k, Num i) => Positive i+positiveVal = PositiveUnsafe . fromIntegral $ natVal @k Proxy++instance (FromHttpApiData a, Show a, Ord a, Num a) => FromHttpApiData (Positive a) where+    parseUrlPiece t = parseUrlPiece @a t >>= toPositive++instance ToHttpApiData a => ToHttpApiData (Positive a) where+    toUrlPiece = toUrlPiece @a . unPositive

@@ -0,0 +1,55 @@+-- | Verious information about your API.+module Servant.Util.Stats+    ( methodsCoveringAPI+    ) where++import Universum++import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)+import Network.HTTP.Types.Method (Method, StdMethod)+import Servant (EmptyAPI, Raw, ReflectMethod (..), Verb, (:<|>), (:>))++-------------------------------------------------------------------------+-- CORS methods coherence+-------------------------------------------------------------------------++-- | Whether a given type item is element of a given list.+type family IsElemBool (x :: StdMethod) (l :: [StdMethod]) :: Bool where+    IsElemBool x (x : _) = 'True+    IsElemBool x (y : xs) = IsElemBool x xs+    IsElemBool x '[] = 'False++type family FailOnDissallowedMethod (method :: StdMethod) (allowed :: Bool) :: Constraint where+    FailOnDissallowedMethod _ 'True = ()+    FailOnDissallowedMethod m 'False = TypeError+        ( 'Text "Method " ':$$: 'ShowType m ':$$: 'Text " is not allowed, but appears in API"+        )++-- | Ensure that the given api uses only methods from the list provided.+type family ContainsOnlyMethods (methods :: [StdMethod]) api :: Constraint where+    ContainsOnlyMethods ms ((path :: Symbol) :> sub) = ContainsOnlyMethods ms sub+    ContainsOnlyMethods ms (part :> sub) = ContainsOnlyMethods ms sub+    ContainsOnlyMethods ms (api1 :<|> api2) = (ContainsOnlyMethods ms api1,+                                               ContainsOnlyMethods ms api2)+    ContainsOnlyMethods ms (Verb m _ _ _) = FailOnDissallowedMethod m (IsElemBool m ms)+    ContainsOnlyMethods ms Raw = ()+    ContainsOnlyMethods ms EmptyAPI = ()++-- | 'ReflectMethod' lifted to method lists.+class ReflectMethods (methods :: [StdMethod]) where+    reflectMethods :: Proxy methods -> [Method]+instance ReflectMethods '[] where+    reflectMethods _ = []+instance (ReflectMethod m, ReflectMethods ms) => ReflectMethods (m ': ms) where+    reflectMethods _ = reflectMethod @m Proxy : reflectMethods @ms Proxy++-- | For the given list of methods, ensure only they are used in API, and get corresponding+-- 'Method' terms.+--+-- A primary use case for this function is specifying CORS methods where we need to think+-- about each single method we allow, thus expecting methods list to be specified manually.+methodsCoveringAPI+    :: forall methods api.+       (ContainsOnlyMethods methods api, ReflectMethods methods)+    => [Method]+methodsCoveringAPI = reflectMethods @methods Proxy

@@ -0,0 +1,156 @@+module Servant.Util.Swagger+    ( ParamDescription+    , DescribedParam+    , paramDescription++    , QueryFlagDescription++    , SwaggerrizeApi+    ) where++import Universum++import Control.Exception (assert)+import Control.Lens (_head, ix, makePrisms, zoom, (?=))+import qualified Data.Swagger as S+import GHC.TypeLits (KnownSymbol, Symbol)+import Servant (Capture', Description, EmptyAPI, NoContent, QueryFlag, QueryParam', Raw, StdMethod,+                Verb, (:<|>), (:>))+import Servant.Swagger (HasSwagger (..))++import Servant.Util.Common++makePrisms ''S.Referenced++----------------------------------------------------------------------------+-- Parameter description+----------------------------------------------------------------------------++-- | Description of parameter.+--+-- Unfortunatelly, @servant-swagger@ package, when deriving description of+-- an endpoint parameter, fills its description for you and makes you implement+-- just 'ParamSchema' which has no description field.+-- To circumvent that you can define description in instance of this type family+-- and later override swagger derivation accordingly.+type family ParamDescription a :: Symbol++type DescribedParam a = (S.ToParamSchema a, KnownSymbol (ParamDescription a))++-- | Set description according to 'ParamDescription' definition.+paramDescription+    :: forall a proxy.+       KnownSymbol (ParamDescription a)+    => proxy a -> Text+paramDescription _ = symbolValT @(ParamDescription a)++----------------------------------------------------------------------------+-- Capture description+----------------------------------------------------------------------------++-- | Like 'Capture', but does not modify description of 404 error (which looks+-- pretty like robot-generated).+-- See 'Servant.Util.Combinators.ErrorResponses' module for manual errors+-- definition.+data SwaggerCapture (mods :: [*]) (sym :: Symbol) a++instance (HasSwagger (Capture' mods sym a :> api), HasSwagger api) =>+         HasSwagger (SwaggerCapture mods sym a :> api) where+    toSwagger _ =+        toSwagger (Proxy @(Capture' mods sym a :> api))+            & desc404L .~ fromMaybe "" pureDesc404+      where+        desc404L :: Traversal' S.Swagger Text+        desc404L = S.allOperations . S.responses . S.responses .+                   ix 404 . _Inline . S.description+        pureDesc404 = toSwagger (Proxy @api) ^? desc404L++----------------------------------------------------------------------------+-- QueryParam description+----------------------------------------------------------------------------++-- | Like 'QueryParam', but does not modify description of 404 error.+-- See 'Servant.Util.Combinators.ErrorResponses' module for manual errors+-- definition.+data SwaggerQueryParam (mods :: [*]) (sym :: Symbol) a++instance (HasSwagger (QueryParam' mods sym a :> api), HasSwagger api) =>+         HasSwagger (SwaggerQueryParam mods sym a :> api) where+    toSwagger _ =+        toSwagger (Proxy @(QueryParam' mods sym a :> api))+            & desc404L .~ fromMaybe "" pureDesc404+      where+        desc404L :: Traversal' S.Swagger Text+        desc404L = S.allOperations . S.responses . S.responses .+                   ix 404 . _Inline . S.description+        pureDesc404 = toSwagger (Proxy @api) ^? desc404L++----------------------------------------------------------------------------+-- Query flag description+----------------------------------------------------------------------------++-- | Defines swagger description for the given `QueryFlag` parameter.+type family QueryFlagDescription (name :: Symbol) :: Symbol++-- | Replacement for 'QueryFlag' which has a better documentation.+data SwaggerQueryFlag (name :: Symbol)++type instance QueryFlagDescription "onlyCount" =+    "If this parameter is present, return only the total count of items."++instance (HasSwagger subApi, KnownSymbol name, KnownSymbol (QueryFlagDescription name)) =>+         HasSwagger (SwaggerQueryFlag name :> subApi) where+    toSwagger _ = toSwagger (Proxy @(QueryFlag name :> subApi)) `executingState` do+        zoom (S.allOperations . S.parameters . _head . _Inline) $ do+            paramName <- use S.name+            assert (name == paramName) pass+            S.description ?= desc+      where+        name = symbolValT @name+        desc = symbolValT @(QueryFlagDescription name)++----------------------------------------------------------------------------+-- Global+----------------------------------------------------------------------------++{- | This applies following transformations to API for the sake of better swagger+documentation.++* Response of methods returning `()` is replaced with `NoContents` (otherwise invalid+swagger is generated).++* `Capture`s and `QueryParam`s are attached a description according to+'ParamDescription' type family (default description is empty).++* @QueryFlag name@ occurences are attached descriptions according to+@ParamsDescription (QueryFlagDescription name)@ (there was no description by default).+-}+type family SwaggerrizeApi api where+    SwaggerrizeApi ((path :: Symbol) :> api) =+        path :> SwaggerrizeApi api++    SwaggerrizeApi (Capture' mods sym a :> api) =+        SwaggerCapture (Description (ParamDescription a) ': mods) sym a :> SwaggerrizeApi api++    SwaggerrizeApi (QueryParam' mods sym a :> api) =+        SwaggerQueryParam (Description (ParamDescription a) ': mods) sym a+        :> SwaggerrizeApi api++    SwaggerrizeApi (QueryFlag name :> api) =+        SwaggerQueryFlag name :> SwaggerrizeApi api++    SwaggerrizeApi (arg :> api) =+        arg :> SwaggerrizeApi api++    SwaggerrizeApi (api1 :<|> api2) =+        SwaggerrizeApi api1 :<|> SwaggerrizeApi api2++    SwaggerrizeApi (Verb (method :: StdMethod) (code :: Nat) ctx ()) =+        Verb method code ctx NoContent++    SwaggerrizeApi (Verb (method :: StdMethod) (code :: Nat) ctx a) =+        Verb method code ctx a++    SwaggerrizeApi Raw = Raw++    SwaggerrizeApi EmptyAPI = EmptyAPI

@@ -0,0 +1,9 @@+-- | Some common utilities.+module Servant.Util.Util+    ( Positive (..)+    , toPositive+    , unsafeToPositive+    , positiveVal+    ) where++import Servant.Util.Internal.Util

@@ -0,0 +1,7 @@+import Spec (spec)+import Test.Hspec (hspec)++import Universum++main :: IO ()+main = hspec spec

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,38 @@+module Test.Servant.Filtering.GeneralSpec where++import Universum++import qualified Data.Map as M+import qualified Data.Set as S+import Test.Hspec (Spec, it)+import Test.QuickCheck (property)++import Servant.Util.Combinators.Filtering.Base+import Servant.Util.Combinators.Filtering.Support++-- | Traverses given filter types and ensures that defined operation+-- names are consistent.+class FilterOpsMatch (filters :: [* -> *]) where+    filterOpsMatch :: Either Text ()++instance FilterOpsMatch '[] where+    filterOpsMatch = pass++instance (IsAutoFilter filter, FilterOpsMatch filters) =>+         FilterOpsMatch (filter ': filters) where+    filterOpsMatch = do+        let opsEng = S.fromList . map fst $ autoFilterEnglishOpsNames @filter+        let opsP = M.keysSet $ autoFilterParsers @filter @() Proxy+        unless (opsEng == opsP) $+            Left $ "autoFilterParsers and autoFilterEnglishOpsNames \+                   \define different set of operations \+                   \(" <> show opsP <> " and " <> show opsEng <> ")"++        filterOpsMatch @filters++spec :: Spec+spec = do+    it "autoFilterParsers & autoFilterEnglishOpsNames return \+       \the same set of operations" $++        property $ either error id $ filterOpsMatch @AllFilterTypes

@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedLists #-}++module Test.Servant.Filtering.ImplSpec where++import Universum++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.TH as Aeson+import Data.Swagger (ToSchema)+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)+import Data.Time.Clock (UTCTime (..))+import Servant.API (Get, JSON, (:>))+import Servant.API.Generic (ToServantApi, (:-))+import Servant.Server.Generic (AsServer)+import Servant.Swagger (toSwagger)++import Test.Hspec (Spec, aroundAll, describe, it)+import Test.Hspec.Expectations (shouldBe)++import Servant.Util+import Servant.Util.Dummy++import Test.Servant.Helpers++-- Data model+---------------------------------------------------------------------------++newtype Isbn = Isbn Word64+  deriving (Show, Eq, Ord, Generic)++instance ToSchema Isbn++Aeson.deriveJSON Aeson.defaultOptions ''Isbn++data Book = Book+  { isbn      :: Isbn+  , name      :: Text+  , rating    :: Word8+  , createdAt :: UTCTime+  } deriving (Show, Eq, Generic)++instance ToSchema Book++Aeson.deriveJSON Aeson.defaultOptions ''Book++-- | Some strictly monotonic function from integers to time.+toUTCTime :: Integer -> UTCTime+toUTCTime idx = UTCTime (fromOrdinalDate idx 0) 0++allBooks :: [Book]+allBooks =+  [ Book+    { isbn = Isbn 1+    , name = "Delving into memes"+    , rating = 5+    , createdAt = toUTCTime 3+    }++  , Book+    { isbn = Isbn 2+    , name = "How to cook tofu, the bright way"+    , rating = 5+    , createdAt = toUTCTime 1+    }++  , Book+    { isbn = Isbn 3+    , name = "Book of something"+    , rating = 4+    , createdAt = toUTCTime 8+    }++  ]++-- Server+---------------------------------------------------------------------------++newtype ApiMethods route = ApiMethods+  { amSimpleFilter+      :: route+      :- "simple"+      :> FilteringParams+          [ "name" ?: 'AutoFilter Text+          , "rating" ?: 'AutoFilter Word8+          , "createdAt" ?: 'AutoFilter UTCTime+          , "isLegendary" ?: 'ManualFilter Bool+          ]+      :> Get '[JSON] [Book]++  } deriving Generic++apiHandlers :: ApiMethods AsServer+apiHandlers = ApiMethods+  { amSimpleFilter = \filterSpec -> do+      let filterApp Book{..} =+            filterOn @"name" name .*.+            filterOn @"rating" rating .*.+            filterOn @"createdAt" createdAt .*.+            manualFilter @"isLegendary"+              (\isLegendary -> (rating == 5) == isLegendary) .*.+            HNil+      return $ filterBySpec filterSpec filterApp allBooks++  }++-- Swagger+---------------------------------------------------------------------------++-- Normally such generic types are not used in API,+-- but in these tests we do not define newtype wrappers.+type instance ParamDescription Text = "Some text"+type instance ParamDescription Word8 = "Rating"+type instance ParamDescription UTCTime = "Creation time"+type instance ParamDescription Bool = "Some flag"++-- You can try this with ghci+printFilterSwagger :: IO ()+printFilterSwagger =+  writeFile "filter-test-swagger.json" $+    decodeUtf8 . Aeson.encode $+    toSwagger $ Proxy @(ToServantApi ApiMethods)++-- Tests+---------------------------------------------------------------------------++spec :: Spec+spec =+  aroundAll (runTestServer apiHandlers) $ do++    describe "Simple filter" $ do++      it "No filtering" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter noFilters+          map isbn res `shouldBe` [Isbn 1, Isbn 2, Isbn 3]++      it "Filtering with exact match" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#rating ?/= 4]+          map isbn res `shouldBe` [Isbn 3]++      it "Filtering with comparison" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#createdAt ?/>= toUTCTime 5]+          map isbn res `shouldBe` [Isbn 3]++      it "Multiple filters" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#rating ?/= 5, #createdAt ?/< toUTCTime 2]+          map isbn res `shouldBe` [Isbn 2]++      it "Manual filter" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#isLegendary ?/~ True]+          map isbn res `shouldBe` [Isbn 1, Isbn 2]++    describe "Regex filters (dummy implementation)" $ do++      it "Contains match" $+        \ApiMethods{..} -> do+          do+            res <- amSimpleFilter [#name `textContains` "tofu"]+            map isbn res `shouldBe` [Isbn 2]++          do+            res <- amSimpleFilter [#name `textContains` "h"]+            map isbn res `shouldBe` [Isbn 2, Isbn 3]++      it "Contains case-insensitive match" $+        \ApiMethods{..} -> do+          do+            res <- amSimpleFilter [#name `textIContains` "b"]+            map isbn res `shouldBe` [Isbn 2, Isbn 3]++          do+            res <- amSimpleFilter [#name `textIContains` "B"]+            map isbn res `shouldBe` [Isbn 2, Isbn 3]++      it "Like: basic behaviour" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#name `textLike` "*ook *"]+          map isbn res `shouldBe` [Isbn 2, Isbn 3]++      it "Like: sticks to edges by default" $+        \ApiMethods{..} -> do+          res <- amSimpleFilter [#name `textLike` "*g"]+          map isbn res `shouldBe` [Isbn 3]+          -- ↑ May also return Isbn 2 since it contains @g@ in the middle,+          -- but that would be not according to the spec.

@@ -0,0 +1,22 @@+module Test.Servant.Filtering.LikeSpec where++import Test.Hspec (Spec, describe, it)+import Universum++import Servant.Util.Combinators.Filtering.Filters.Like++spec :: Spec+spec = do+    describe "LikePattern verification on construction" $ do+        it "Normal" $+            isRight $ mkLikePattern "abac.*."+        it "Lone escape" $+            isLeft $ mkLikePattern "a\\bac.*."+        it ". escaped" $+            isRight $ mkLikePattern "abac\\.*."+        it "* escaped" $+            isRight $ mkLikePattern "abac.\\*."+        it "Escape escaped" $+            isRight $ mkLikePattern "ab\\\\ac.*."+        it "Terminating escape" $+            isLeft $ mkLikePattern "abac.*.\\"

@@ -0,0 +1,69 @@+module Test.Servant.Helpers+    ( runTestServer+    , runTestServerE+    ) where++import Universum++import Control.Monad.Except (liftEither)+import Network.HTTP.Client (defaultManagerSettings, newManager)+import Network.Wai.Handler.Warp (Port, testWithApplication)+import Servant.API.Generic (GenericServant, ToServant, ToServantApi)+import Servant.Client (BaseUrl (..), Client, ClientEnv, ClientError, ClientM, HasClient,+                       Scheme (Http), mkClientEnv, runClientM)+import Servant.Client.Generic (AsClientT, genericClientHoist)+import Servant.Server (HasServer, Server)+import Servant.Server.Generic (AsServer, genericServe)++mkTestClientEnv :: Port -> IO ClientEnv+mkTestClientEnv port = do+  manager <- newManager defaultManagerSettings+  let baseUrl = BaseUrl+        { baseUrlScheme = Http+        , baseUrlHost = "localhost"+        , baseUrlPort = port+        , baseUrlPath = ""+        }+  return $ mkClientEnv manager baseUrl++-- | Runs server and returns client handlers to it.+--+-- This version returns client handlers where errors are returned+-- explicitly.+runTestServerE+  :: ( GenericServant methods AsServer+     , HasServer (ToServantApi methods) '[]+     , Server (ToServantApi methods) ~ ToServant methods AsServer+     , GenericServant methods (AsClientT (ExceptT ClientError IO))+     , HasClient ClientM (ToServantApi methods)+     , Client (ExceptT ClientError IO) (ToServantApi methods)+         ~ ToServant methods (AsClientT (ExceptT ClientError IO))+     )+  => methods AsServer+  -> (methods (AsClientT (ExceptT ClientError IO)) -> IO ())+  -> IO ()+runTestServerE handlers acceptClientHandlers =+  testWithApplication (pure $ genericServe handlers) $ \port -> do+    cliEnv <- mkTestClientEnv port+    acceptClientHandlers $+      genericClientHoist (lift . flip runClientM cliEnv >=> liftEither)++-- | Runs server and returns client handlers to it.+--+-- In case a client handler fails, the exception will be propagated.+runTestServer+  :: ( GenericServant methods AsServer+     , HasServer (ToServantApi methods) '[]+     , Server (ToServantApi methods) ~ ToServant methods AsServer+     , GenericServant methods (AsClientT IO)+     , HasClient ClientM (ToServantApi methods)+     , Client IO (ToServantApi methods) ~ ToServant methods (AsClientT IO)+     )+  => methods AsServer+  -> (methods (AsClientT IO) -> IO ())+  -> IO ()+runTestServer handlers acceptClientHandlers =+  testWithApplication (pure $ genericServe handlers) $ \port -> do+    cliEnv <- mkTestClientEnv port+    acceptClientHandlers $+      genericClientHoist (flip runClientM cliEnv >=> either throwM pure)

@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedLists #-}++module Test.Servant.Pagination.ImplSpec where++import Universum++import qualified Data.Aeson as Aeson+import Servant.API (Get, JSON, (:>))+import Servant.API.Generic (ToServantApi, (:-))+import Servant.Server.Generic (AsServer)+import Servant.Swagger (toSwagger)++import Test.Hspec (Spec, aroundAll, describe, it)+import Test.Hspec.Expectations (shouldBe)++import Servant.Util+import Servant.Util.Dummy++import Test.Servant.Helpers++-- Server+---------------------------------------------------------------------------++data ApiMethods route = ApiMethods+  { amSimplePaginate+      :: route+      :- "simple"+      :> PaginationParams 'DefUnlimitedPageSize+      :> Get '[JSON] [Int]++  , amDefPageSizePaginate+      :: route+      :- "defPageSize"+      :> PaginationParams ('DefPageSize 3)+      :> Get '[JSON] [Int]++  } deriving Generic++apiHandlers :: ApiMethods AsServer+apiHandlers = ApiMethods+  { amSimplePaginate = \paginationSpec -> do+      return $ paginate paginationSpec [1..10]++  , amDefPageSizePaginate = \paginationSpec -> do+      return $ paginate paginationSpec [1..10]+  }++-- Swagger+---------------------------------------------------------------------------++-- You can try this with ghci+printPaginationSwagger :: IO ()+printPaginationSwagger =+  writeFile "pagination-test-swagger.json" $+    decodeUtf8 . Aeson.encode $+    toSwagger $ Proxy @(ToServantApi ApiMethods)++-- Tests+---------------------------------------------------------------------------++spec :: Spec+spec =+  aroundAll (runTestServer apiHandlers) $ do++    describe "Simple pagination" $ do++      it "No specific pagination" $+        \ApiMethods{..} -> do+          res <- amSimplePaginate defPageSize+          res `shouldBe` [1..10]++      it "Set page size" $+        \ApiMethods{..} -> do+          res <- amSimplePaginate (itemsOnPage 2)+          res `shouldBe` [1..2]++      it "Set offset" $+        \ApiMethods{..} -> do+          res <- amSimplePaginate (skipping 5 defPageSize)+          res `shouldBe` [6..10]++      it "Set page size and offset" $+        \ApiMethods{..} -> do+          res <- amSimplePaginate (skipping 5 $ itemsOnPage 3)+          res `shouldBe` [6..8]++    describe "Simple pagination" $ do++      it "No specific pagination" $+        \ApiMethods{..} -> do+          res <- amDefPageSizePaginate defPageSize+          res `shouldBe` [1..3]++      it "Set page size" $+        \ApiMethods{..} -> do+          res <- amDefPageSizePaginate (itemsOnPage 5)+          res `shouldBe` [1..5]++      it "Set offset" $+        \ApiMethods{..} -> do+          res <- amDefPageSizePaginate (skipping 5 defPageSize)+          res `shouldBe` [6..8]++      it "Set page size and offset" $+        \ApiMethods{..} -> do+          res <- amDefPageSizePaginate (skipping 5 $ itemsOnPage 1)+          res `shouldBe` [6]

@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedLists #-}++module Test.Servant.Sorting.ImplSpec where++import Universum++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.TH as Aeson+import Data.Swagger (ToSchema)+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)+import Data.Time.Clock (UTCTime (..))+import Servant.API (Get, JSON, (:>))+import Servant.API.Generic (ToServantApi, (:-))+import Servant.Server.Generic (AsServer)+import Servant.Swagger (toSwagger)++import Test.Hspec (Spec, aroundAll, describe, it)+import Test.Hspec.Expectations (shouldBe)++import Servant.Util+import Servant.Util.Dummy++import Test.Servant.Helpers++-- Data model+---------------------------------------------------------------------------++newtype Isbn = Isbn Word64+  deriving (Show, Eq, Ord, Generic)++instance ToSchema Isbn++Aeson.deriveJSON Aeson.defaultOptions ''Isbn++data Book = Book+  { isbn      :: Isbn+  , name      :: Text+  , rating    :: Word8+  , createdAt :: UTCTime+  } deriving (Show, Eq, Generic)++instance ToSchema Book++Aeson.deriveJSON Aeson.defaultOptions ''Book++-- | Some strictly monotonic function from integers to time.+toUTCTime :: Integer -> UTCTime+toUTCTime idx = UTCTime (fromOrdinalDate idx 0) 0++allBooks :: [Book]+allBooks =+  [ Book+    { isbn = Isbn 111+    , name = "How to cook tofu, the right way"+    , rating = 5+    , createdAt = toUTCTime 1+    }++  , Book+    { isbn = Isbn 100+    , name = "Delving into memes"+    , rating = 5+    , createdAt = toUTCTime 3+    }++  , Book+    { isbn = Isbn 120+    , name = "Book of something"+    , rating = 4+    , createdAt = toUTCTime 8+    }++  ]++-- Server+---------------------------------------------------------------------------++data ApiMethods route = ApiMethods+  { amSimpleSort+      :: route+      :- "simple"+      :> SortingParams+          [ "name" ?: Text+          , "rating" ?: Word8+          , "createdAt" ?: UTCTime+          ]+         '[ "isbn" ?: 'Asc Isbn+          ]+      :> Get '[JSON] [Book]++  , amOverrideableSort+      :: route+      :- "overrideable"+      :> SortingParams+          [ "rating" ?: Word8+          , "createdAt" ?: UTCTime+          , "isbn" ?: Isbn+          ]+          [ "rating" ?: 'Desc Word8+          , "isbn" ?: 'Asc Isbn+          ]+      :> Get '[JSON] [Book]++  , amOverrideableSort2+      :: route+      :- "overrideable2"+      :> SortingParams+          [ "isbn" ?: Isbn+          , "rating" ?: Word8+          ]+          [ "isbn" ?: 'Asc Isbn+          , "rating" ?: 'Asc Word8+          ]+      :> Get '[JSON] [Book]++  } deriving Generic++apiHandlers :: ApiMethods AsServer+apiHandlers = ApiMethods+  { amSimpleSort = \sortingSpec -> do+      let sortingApp Book{..} =+            fieldSort @"name" name .*.+            fieldSort @"rating" rating .*.+            fieldSort @"createdAt" createdAt .*.+            fieldSort @"isbn" isbn .*.+            HNil+      return $ sortBySpec sortingSpec sortingApp allBooks++  , amOverrideableSort = \sortingSpec -> do+      let sortingApp Book{..} =+            fieldSort @"rating" rating .*.+            fieldSort @"createdAt" createdAt .*.+            fieldSort @"isbn" isbn .*.+            fieldSort @"rating" rating .*.+            fieldSort @"isbn" isbn .*.+            HNil+      return $ sortBySpec sortingSpec sortingApp allBooks++  , amOverrideableSort2 = \sortingSpec -> do+      let sortingApp Book{..} =+            fieldSort @"isbn" isbn .*.+            fieldSort @"rating" rating .*.+            fieldSort @"isbn" isbn .*.+            fieldSort @"rating" rating .*.+            HNil+      return $ sortBySpec sortingSpec sortingApp allBooks++  }++-- Swagger+---------------------------------------------------------------------------++-- You can try this with ghci+printSortingSwagger :: IO ()+printSortingSwagger =+  writeFile "sorting-test-swagger.json" $+    decodeUtf8 . Aeson.encode $+    toSwagger $ Proxy @(ToServantApi ApiMethods)++-- Tests+---------------------------------------------------------------------------++spec :: Spec+spec =+  aroundAll (runTestServer apiHandlers) $ do++    describe "Simple sort with base sorting" $ do++      it "No sorting (sole base)" $+        \ApiMethods{..} -> do+          res <- amSimpleSort noSorting+          map isbn res `shouldBe` [Isbn 100, Isbn 111, Isbn 120]++      it "Fully determining sorting (base doesn't matter)" $+        \ApiMethods{..} -> do+          res <- amSimpleSort [asc #createdAt]+          map isbn res `shouldBe` [Isbn 111, Isbn 100, Isbn 120]++      it "Partially determining sorting (base matters)" $+        \ApiMethods{..} -> do+          res <- amSimpleSort [asc #rating]+          map isbn res `shouldBe` [Isbn 120, Isbn 100, Isbn 111]++    describe "Simple sort with overridable base sorting" $ do++      it "No sorting (sole base)" $+        \ApiMethods{..} -> do+          res <- amOverrideableSort noSorting+          map isbn res `shouldBe` [Isbn 100, Isbn 111, Isbn 120]++      it "Base sorting can be overriden" $+        \ApiMethods{..} -> do+          res <- amOverrideableSort [desc #isbn]+          map isbn res `shouldBe` [Isbn 120, Isbn 111, Isbn 100]++      it "Overriden base sorting tolerates the provided sorting order" $+        -- One possible bug is on @rating+,createdAt+@ request ignore @rating+@+        -- since it is part of base sorting. But base sorting matters last, so+        -- that wouldn't be valid.+        \ApiMethods{..} -> do+          res <- amOverrideableSort [asc #rating, asc #createdAt]+          map isbn res `shouldBe` [Isbn 120, Isbn 111, Isbn 100]++      it "Overriden field from base sorting doesn't cancel the remaining base sorting" $+        \ApiMethods{..} -> do+          res <- amOverrideableSort2 [asc #rating]+          map isbn res `shouldBe` [Isbn 120, Isbn 100, Isbn 111]