servant-routes (empty) → 0.1.0.0

raw patch · 31 files changed

+2757/−0 lines, 31 filesdep +QuickCheckdep +aesondep +aeson-pretty

Dependencies added: QuickCheck, aeson, aeson-pretty, base, containers, hspec, http-types, microlens, microlens-th, servant, servant-routes, text

Files

• CHANGELOG.md +21/−0
• LICENSE +30/−0
• README.md +465/−0
• servant-routes.cabal +120/−0
• src/Servant/API/Routes.hs +498/−0
• src/Servant/API/Routes/Auth.hs +47/−0
• src/Servant/API/Routes/Header.hs +16/−0
• src/Servant/API/Routes/Internal/Auth.hs +33/−0
• src/Servant/API/Routes/Internal/Header.hs +72/−0
• src/Servant/API/Routes/Internal/Param.hs +71/−0
• src/Servant/API/Routes/Internal/Path.hs +65/−0
• src/Servant/API/Routes/Internal/Request.hs +75/−0
• src/Servant/API/Routes/Internal/Response.hs +122/−0
• src/Servant/API/Routes/Internal/Route.hs +66/−0
• src/Servant/API/Routes/Internal/Some.hs +129/−0
• src/Servant/API/Routes/Param.hs +50/−0
• src/Servant/API/Routes/Path.hs +68/−0
• src/Servant/API/Routes/Request.hs +49/−0
• src/Servant/API/Routes/Response.hs +50/−0
• src/Servant/API/Routes/Route.hs +87/−0
• src/Servant/API/Routes/Utils.hs +37/−0
• test/Servant/API/Routes/HeaderSpec.hs +32/−0
• test/Servant/API/Routes/ParamSpec.hs +25/−0
• test/Servant/API/Routes/PathSpec.hs +94/−0
• test/Servant/API/Routes/RequestSpec.hs +33/−0
• test/Servant/API/Routes/ResponseSpec.hs +42/−0
• test/Servant/API/Routes/RouteSpec.hs +76/−0
• test/Servant/API/Routes/SomeSpec.hs +57/−0
• test/Servant/API/Routes/Util.hs +12/−0
• test/Servant/API/RoutesSpec.hs +214/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,21 @@+# Changelog++All notable changes to `servant-routes` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org).++## [Unreleased]++## [0.1.0.0] - 03.05.2025++### Added++- First edition of the package.+- 100% documentation coverage.+- Almost 100% test coverage.+- Reasonably detailed README.+- CI that builds and tests the package for each version of GHC in the `tested-with` field.++[unreleased]: https://github.com/fpringle/servant-routes/compare/v0.1.0.0...HEAD+[0.1.0.0]: https://github.com/fpringle/servant-routes/releases/tag/v0.1.0.0

@@ -0,0 +1,30 @@+Copyright (c) 2025, Frederick Pringle++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Frederick Pringle nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,465 @@+# servant-routes++This package alllows us to automatically convert type-level Servant representations of APIs to concrete term-level representations.++See `Servant.API.Routes` for in-depth documentation.++## Contents++* [Motivation](#motivation)+* [Examples](#examples)+    * [Basic usage with servant combinators](#basic-usage-with-servant-combinators)+    * [Same example using NamedRoutes](#same-example-using-namedroutes)+    * [Writing HasRoutes instances for custom combinators](#writing-hasroutes-instances-for-custom-combinators)+* [Back story](#back-story)+++## Motivation++Refactoring Servant API types is quite error-prone, especially when you have to move+around lots of `:<|>`s and `:>`s.  So it's very possible that the route structure could+change in that refactoring, _without being caught by the type-checker_.++The `HasRoutes` class could help as a "golden test" - run `getRoutes` before and after the refactor, and if they give the same+result you can be much more confident that the refactor didn't introduce difficult bugs.++Another use-case is in testing: some Haskellers use type families to modify Servant APIs, for example+to add endpoints or authorisation headers. Types are hard to test, but terms are easy. Use `HasRoutes`+and run your tests on `Routes`.+++## Examples++#### Basic usage with `servant` combinators:++```haskell+type ServantAPI =+  "users"+    :> ( "list" :> Get '[JSON] [User]+          :<|> "create" :> ReqBody '[JSON] UserCreateData :> Post '[JSON] UserID+          :<|> "detail"+            :> QueryParam' '[Required] "id" UserID+            :> Header' '[Required] "x-api-key" ApiKey+            :> Get '[JSON] User+       )+    :<|> "transactions"+      :> ( Capture "id" TransactionID+            :> Get '[JSON] (Headers '[Header "x-request-id" RequestID] Transaction)+         )+    :<|> "admin"+      :> BasicAuth "admin" User+      :> ( "users" :> "delete" :> CaptureAll "ids" UserID :> Delete '[JSON] UserID+         )+```++```haskell+ghci> printRoutes @ServantAPI+GET /users/list+POST /users/create+GET /users/detail?id=<UserID>+GET /transactions/<TransactionID>+DELETE /admin/users/delete/<[UserID]>++ghci> BL.putStrLn . encodePretty $ getRoutes @ServantAPI -- using aeson-pretty+```++<details>+<summary>Click to see JSON output</summary>+  +```json+[+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/users/list",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "[User]"+        }+    },+    {+        "auths": [],+        "method": "POST",+        "params": [],+        "path": "/users/create",+        "request_body": "UserCreateData",+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "UserID"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [+            {+                "name": "id",+                "param_type": "UserID",+                "type": "SingleParam"+            }+        ],+        "path": "/users/detail",+        "request_body": null,+        "request_headers": [+            {+                "name": "x-api-key",+                "type": "ApiKey"+            }+        ],+        "response": {+            "headers": [],+            "type": "User"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/transactions/<TransactionID>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "x-request-id",+                    "type": "RequestID"+                }+            ],+            "type": "Transaction"+        }+    },+    {+        "auths": [+            "Basic admin"+        ],+        "method": "DELETE",+        "params": [],+        "path": "/admin/users/delete/<[UserID]>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "UserID"+        }+    }+]+```++</details>++#### Same example using `NamedRoutes`:++```haskell+data UserAPI mode = UserAPI+  { list :: mode :- "list" :> Get '[JSON] [User]+  , create :: mode :- "create" :> ReqBody '[JSON] UserCreateData :> Post '[JSON] UserID+  , detail ::+      mode+        :- "detail"+          :> QueryParam' '[Required] "id" UserID+          :> Header' '[Required] "x-api-key" ApiKey+          :> Get '[JSON] User+  }+  deriving (Generic)++newtype TransactionAPI mode = TransactionAPI+  { get ::+      Capture "id" TransactionID+        :> Get '[JSON] (Headers '[Header "x-request-id" RequestID] Transaction)+  }+  deriving (Generic)++newtype AdminAPI mode = AdminAPI+  { deleteUsers ::+      BasicAuth "admin" User+        :> "users"+        :> "delete"+        :> CaptureAll "ids" UserID+        :> Delete '[JSON] UserID+  }+  deriving (Generic)++data ServantAPIWithNamedRoutes mode = ServantAPIWithNamedRoutes+  { users :: mode :- "users" :> NamedRoutes UserAPI+  , transactions :: mode :- "transactions" :> NamedRoutes TransactionAPI+  , admin :: mode :- "admin" :> NamedRoutes AdminAPI+  }+  deriving (Generic)+```++```haskell+ghci> printRoutes @(NamedRoutes ServantAPIWithNamedRoutes)+GET /users/list+POST /users/create+GET /users/detail?id=<UserID>+GET /transactions/<TransactionID>+DELETE /admin/users/delete/<[UserID]>++ghci> BL.putStrLn . encodePretty $ getRoutes @(NamedRoutes ServantAPIWithNamedRoutes)+```++<details>+<summary>Click to see JSON output</summary>++Note this is the same as above, so we know we refactored `ServantAPI` to `ServantAPIWithNamedRoutes` correctly!+  +```json+[+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/users/list",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "[User]"+        }+    },+    {+        "auths": [],+        "method": "POST",+        "params": [],+        "path": "/users/create",+        "request_body": "UserCreateData",+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "UserID"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [+            {+                "name": "id",+                "param_type": "UserID",+                "type": "SingleParam"+            }+        ],+        "path": "/users/detail",+        "request_body": null,+        "request_headers": [+            {+                "name": "x-api-key",+                "type": "ApiKey"+            }+        ],+        "response": {+            "headers": [],+            "type": "User"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/transactions/<TransactionID>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "x-request-id",+                    "type": "RequestID"+                }+            ],+            "type": "Transaction"+        }+    },+    {+        "auths": [+            "Basic admin"+        ],+        "method": "DELETE",+        "params": [],+        "path": "/admin/users/delete/<[UserID]>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [],+            "type": "UserID"+        }+    }+]++```++</details>++#### Writing `HasRoutes` instances for custom combinators:++For the most part you'll be able to use `getRoutes` out of the box, without worrying about `HasRoutes` and other internals.+But sometimes you'll want to extend `servant` with your own custom combinators, writing `HasServer` or `HasClient` for them etc.+Then you'll also need to write a `HasRoutes` instance.++Let's write a `HasRoutes` instance for the `Replay` combinator in William Yao's+[Writing servant combinators for fun and profit](https://williamyaoh.com/posts/2023-02-28-writing-servant-combinators.html#:~:text=Example%3A%20Returning%20a%20header%20with%20a%20%22replay%22%20path).+The `HasServer` instance tells us that the effect of `Replay :> api` is to inherit the behaviour of `api`, but add an `X-Replay-Path` header of type `ByteString` to the response.++As far as our `HasRoutes` instance is concerned, this means that we need to:++1. Call `getRoutes` on `api` to get the list of un-modified routes+2. Add a `HeaderRep` to the `responseHeaders` field of all the possible responses of each route, with name `X-Replay-Path` and type-rep `ByteString`.++```haskell+data Replay++instance HasRoutes api => HasRoutes (Replay :> api) where+  getRoutes =+    let apiRoutes = getRoutes @api+        replayHeader = mkHeaderRep @"X-Replay-Path" @ByteString+        addHeader route = route & routeResponse . unResponses . traversed . responseHeaders %~ Set.insert replayHeader+    in  addHeader <$> apiRoutes+```++We can test the implementation on `ServantAPI` from above:++```haskell+ghci> BL.putStrLn . encodePretty $ getRoutes @(Replay :> ServantAPI)+```++<details>+<summary>Click to see JSON output</summary>++Note that each route is the same as above, but with an extra `response.header` `{"name": "X-Replay-Path", "type": "ByteString"}`:+  +```json+[+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/users/list",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "X-Replay-Path",+                    "type": "ByteString"+                }+            ],+            "type": "[User]"+        }+    },+    {+        "auths": [],+        "method": "POST",+        "params": [],+        "path": "/users/create",+        "request_body": "UserCreateData",+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "X-Replay-Path",+                    "type": "ByteString"+                }+            ],+            "type": "UserID"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [+            {+                "name": "id",+                "param_type": "UserID",+                "type": "SingleParam"+            }+        ],+        "path": "/users/detail",+        "request_body": null,+        "request_headers": [+            {+                "name": "x-api-key",+                "type": "ApiKey"+            }+        ],+        "response": {+            "headers": [+                {+                    "name": "X-Replay-Path",+                    "type": "ByteString"+                }+            ],+            "type": "User"+        }+    },+    {+        "auths": [],+        "method": "GET",+        "params": [],+        "path": "/transactions/<TransactionID>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "X-Replay-Path",+                    "type": "ByteString"+                },+                {+                    "name": "x-request-id",+                    "type": "RequestID"+                }+            ],+            "type": "Transaction"+        }+    },+    {+        "auths": [+            "Basic admin"+        ],+        "method": "DELETE",+        "params": [],+        "path": "/admin/users/delete/<[UserID]>",+        "request_body": null,+        "request_headers": [],+        "response": {+            "headers": [+                {+                    "name": "X-Replay-Path",+                    "type": "ByteString"+                }+            ],+            "type": "UserID"+        }+    }+]+```++</details>+++## Back story++The scenario I described in [Motivation](#motivation) arose while I was working with @asheshambasta at [CentralApp](https://www.centralapp.com/),+one of my freelancing clients. The CentralApp backend is a distributed system comprising of 565 Servant endpoints across 7 different services+(plus several more services that aren't using Servant). Many of these endpoints are deeply nested, and as anyone familiar with Servant knows, debugging+error messages can be very frustrating. The best solution to this problem is to use [NamedRoutes](https://hackage.haskell.org/package/servant/docs/Servant-API.html#t:NamedRoutes)+and derive `HasServer` instances using `Generic`. I took on the task of refactoring _every one_ of those 565 endpoints to use `NamedRoutes` instead of+`:<|>` and `:>`.++Not only was this process fiddly and tedious, it was also potentially error-prone. The type-checker helps, of course, and will let you know if you accidentally+swapped 2 handler functions. However, what if you miss out or misspell a path part (e.g. `"api" :> ...`)? These have no effect on the `ServerT` instances, and thus+can't be caught by the type-checker. We wouldn't know if we made this kind of error until after deployment, when an endpoint would suddenly be at completely the wrong location,+or expecting `QueryParam`s with the names switched round, or many other bugs caused by human error.++Having worked with [servant-openapi3](https://hackage.haskell.org/package/servant-openapi3), I got the idea for a much simpler version in order to solve the above problem.+If I could use a similar mechanism to convert API types to term-level values describing the shape and semantics of all the routes of the API, I could compare the+representation _before_ and _after_ the refactoring. If the lists of routes were identical, and assuming my representation of the routes was accurate and expressive enough,+I could be confident that I wasn't introducing any subtle bugs.++Fortunately, this approach worked! After refactoring those 565 endpoints to use `NamedRoutes`, I ran `getRoutes` and compared the output to the output from the commit _before_+the refactor. I used [jdiff](https://github.com/networktocode/jdiff) to compare the outputs in JSON form. The comparison revealed that _one_ endpoint had a subtle bug:+it was missing a path part, as described above. And the type-checker didn't catch the mistake, which confirmed the need for this package!+Having fixed the mistake, I deployed the refactoring without a single issue.

@@ -0,0 +1,120 @@+cabal-version:      3.0+name:               servant-routes+version:            0.1.0.0+synopsis:           Generate route descriptions from Servant APIs+description:+    See the documentation of 'Servant.API.Routes'.+license:            BSD-3-Clause+license-file:       LICENSE+author:             Frederick Pringle+maintainer:         freddyjepringle@gmail.com+copyright:          Copyright(c) Frederick Pringle 2025+homepage:           https://github.com/fpringle/servant-routes+bug-reports:        https://github.com/fpringle/servant-routes/issues+category:           Servant, Web+build-type:         Simple+extra-doc-files:    CHANGELOG.md+                    README.md+tested-with:+    GHC == 8.8.4+  , GHC == 8.10.7+  , GHC == 9.0.2+  , GHC == 9.2.4+  , GHC == 9.2.8+  , GHC == 9.4.2+  , GHC == 9.4.5++source-repository head+  type:           git+  location:       https://github.com/fpringle/servant-routes++common warnings+  ghc-options: -Wall -Wno-unused-do-bind++common deps+  build-depends:+    , base >= 4.13 && < 5+    , servant >= 0.17 && < 0.21+    , aeson >= 2.0 && < 2.3+    , text >= 1.2 && < 2.2+    , http-types >= 0.12 && < 0.13+    , containers >= 0.6 && < 0.8+    , microlens >= 0.4.9 && < 0.5+    , microlens-th >= 0.4.3 && < 0.5+    , aeson-pretty >= 0.8.8 && < 0.9++common extensions+  default-extensions:+    DeriveGeneric+    DerivingVia +    FlexibleContexts+    FlexibleInstances+    LambdaCase+    NamedFieldPuns+    OverloadedStrings+    PackageImports+    RecordWildCards+    ScopedTypeVariables+    TypeApplications+    ViewPatterns+    DataKinds+    AllowAmbiguousTypes+    TypeFamilies+    TypeOperators++library+  import:+      warnings+    , deps+    , extensions+  ghc-options: -Wunused-packages+  exposed-modules:+    Servant.API.Routes+    Servant.API.Routes.Route+    Servant.API.Routes.Header+    Servant.API.Routes.Param+    Servant.API.Routes.Path+    Servant.API.Routes.Request+    Servant.API.Routes.Response+    Servant.API.Routes.Auth++    Servant.API.Routes.Internal.Some+    Servant.API.Routes.Internal.Header+    Servant.API.Routes.Internal.Param+    Servant.API.Routes.Internal.Path+    Servant.API.Routes.Internal.Request+    Servant.API.Routes.Internal.Response+    Servant.API.Routes.Internal.Route+    Servant.API.Routes.Internal.Auth+  other-modules:+    Servant.API.Routes.Utils+  -- other-extensions:+  hs-source-dirs:   src+  default-language: Haskell2010++test-suite servant-routes-test+  import:+      warnings+    , deps+    , extensions+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs+  other-modules:+    Servant.API.RoutesSpec+    Servant.API.Routes.Util+    Servant.API.Routes.RouteSpec+    Servant.API.Routes.HeaderSpec+    Servant.API.Routes.ParamSpec+    Servant.API.Routes.PathSpec+    Servant.API.Routes.RequestSpec+    Servant.API.Routes.ResponseSpec+    Servant.API.Routes.SomeSpec+  build-tool-depends:+      hspec-discover:hspec-discover+  ghc-options:      -Wno-orphans+  build-depends:+    , servant-routes+    , hspec >= 2.9 && < 2.12+    , QuickCheck >= 2.14 && < 2.15

@@ -0,0 +1,498 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      : Servant.API.Routes+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++This package provides two things:++  1. A simple, and probably incomplete, way to represent APIs at the term level.+     This is achieved by the 'Route', t'Routes', 'Path', 'Param', 'HeaderRep',+     'Request', 'Response' and 'Responses' types.+  2. More interestingly, a way to automatically generate the routes from any Servant API.  This is+     accomplished using the 'HasRoutes' typeclass. You can think of this as being a less sophisticated+     version of @HasOpenApi@ from [servant-openapi3](https://hackage.haskell.org/package/servant-openapi3),+     or a more sophisticated version of @layout@ from+     [servant-server](https://hackage.haskell.org/package/servant-server).++= Motivation++Refactoring Servant API types is quite error-prone, especially when you have to move+around lots of ':<|>' and ':>'.  So it's very possible that the route structure could+change in that refactoring, /without being caught by the type-checker/.++The 'HasRoutes' class could help as a golden test - run 'getRoutes' before and after+the refactor, and if they give the same result you can be much more confident that the+refactor didn't introduce difficult bugs.++- Note that 'printRoutes' only includes the path, method and query parameters.+  For more detailed comparison, use the JSON instance of t'Routes', encode the routes to+  a file (before and after the refactoring), and use [jdiff](https://github.com/networktocode/jdiff).++Another use-case is in testing: some Haskellers use type families to modify Servant APIs, for example+to add endpoints or authorisation headers. Types are hard to test, but terms are easy. Use 'HasRoutes'+and run your tests on t'Routes'.+-}+module Servant.API.Routes+  ( -- * API routes+    Route+  , defRoute+  , renderRoute+  , Routes+  , unRoutes+  , pattern Routes++    -- * Automatic generation of routes for Servant API types++    -- | Now we can automatically generate a t'Routes' for any Servant combinator. In most cases+    -- the user should never need to implement 'HasRoutes' unless they're hacking on Servant or+    -- defining their own combinators.+  , HasRoutes (..)+  , printRoutes+  , printRoutesJSON+  , printRoutesJSONPretty++    -- * Types and helper functions++    -- ** URL paths+  , Path+  , rootPath+  , prependPathPart+  , prependCapturePart+  , prependCaptureAllPart+  , renderPath++    -- ** Request/response bodies++    -- *** Requests+  , Request+  , noRequest+  , oneRequest+  , allOfRequests++    -- *** Responses+  , Response+  , responseType+  , responseHeaders+  , Responses+  , noResponse+  , oneResponse+  , oneOfResponses++    -- ** Request/response headers+  , HeaderRep+  , mkHeaderRep++    -- ** Query parameters+  , Param+  , singleParam+  , arrayElemParam+  , flagParam+  , renderParam++    -- ** Auth schemes+  , Auth+  , basicAuth+  , customAuth+  )+where++import Data.Aeson+import Data.Aeson.Encode.Pretty+import qualified Data.Aeson.Key as AK (fromText)+import qualified Data.Aeson.Types as A (Pair)+import Data.Bifunctor (bimap)+import Data.Foldable (foldl', traverse_)+import qualified Data.Map as Map+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Data.Typeable+import GHC.TypeLits (KnownSymbol, Symbol)+import Lens.Micro+import Network.HTTP.Types.Method (Method)+import Servant.API+import Servant.API.Modifiers (RequiredArgument)+import "this" Servant.API.Routes.Auth+import "this" Servant.API.Routes.Header+import "this" Servant.API.Routes.Param+import "this" Servant.API.Routes.Path+import "this" Servant.API.Routes.Request+import "this" Servant.API.Routes.Response+import "this" Servant.API.Routes.Route+import "this" Servant.API.Routes.Utils++{- | To render all of an API's 'Route's as JSON, we need to identify each route by its+ path AND its method (since 2 routes can have the same path but different method).+ This newtype lets us represent this nested structure.+-}+newtype Routes = MkRoutes+  { unRoutes :: Map.Map Path (Map.Map Method Route)+  -- ^ Get the underlying 'Map.Map' of a t'Routes'.+  }+  deriving (Show, Eq)++makeRoutes :: [Route] -> Routes+makeRoutes = MkRoutes . foldl' insert mempty+  where+    insert acc r = Map.insertWith (<>) path subMap acc+      where+        path = r ^. routePath+        method = r ^. routeMethod+        subMap = Map.singleton method r++unmakeRoutes :: Routes -> [Route]+unmakeRoutes = concatMap Map.elems . Map.elems . unRoutes++{- | A smart constructor that allows us to think of a t'Routes' as simply a list of+'Route's, whereas it's actually a 'Map.Map'.+-}+pattern Routes :: [Route] -> Routes+pattern Routes rs <- (unmakeRoutes -> rs)+  where+    Routes = makeRoutes++{-# COMPLETE Routes #-}++instance ToJSON Routes where+  toJSON = object . fmap mkPair . Map.assocs . unRoutes+    where+      mkPair :: (Path, Map.Map Method Route) -> A.Pair+      mkPair = bimap (AK.fromText . renderPath) subMapToJSON++      subMapToJSON :: Map.Map Method Route -> Value+      subMapToJSON = object . fmap mkSubPair . Map.assocs++      mkSubPair (method, r) =+        let key = AK.fromText . TE.decodeUtf8 $ method+        in  key .= r++{- | Get a simple list of all the routes in an API.++One use-case, which was the original motivation for the class, is refactoring Servant APIs+to use 'NamedRoutes'. It's a fiddly, repetitive, and error-prone process, and it's very+easy to make small mistakes. A lot of these errors will be caught by the type-checker, e.g.+if the type signature of a handler function doesn't match the @ServerT@ of its API type.+However there are some errrors that wouldn't be caught by the type-checker, such as missing+out path parts.++For example, if our original API looked like++> type API =+>   "api"+>     :> "v2"+>     :> ( "users" :> Get '[JSON] [User]+>           :<|> "user" :> ReqBody '[JSON] UserData :> Post '[JSON] UserId+>        )+>+> server :: Server API+> server = listUsers :<|> createUser+>   where ...++and we refactored to++> data RefactoredAPI mode = RefactoredAPI+>   { listUsers :: mode :- "api" :> "v2" :> "users" :> Get '[JSON] [User]+>   , createUser :: mode :- "user" :> ReqBody '[JSON] UserData :> Post '[JSON] UserId+>   }+>   deriving Generic+>+> server :: Server (NamedRoutes RefactoredAPI)+> server = RefactoredAPI {listUsers, createUser}+>   where ...++Oops! We forgot the @"api" :> "v2" :>@ in the 2nd sub-endpoint. However, since the @ServerT@ type+is unaffected by adding or remove path parts, this will still compile.++However, if we use 'HasRoutes' as a sanity check:++> ghci> printRoutes @API+> GET /api/v2/users+> POST /api/v2/user+>+> ghci> printRoutes @(NamedRoutes RefactoredAPI)+> GET /api/v2/users+> POST /user++Much clearer to see the mistake. For more detailed output, use the 'ToJSON' instance:++> ghci> BL.putStrLn . encodePretty $ getRoutes @API+> [+>     {+>         "auths": [],+>         "method": "GET",+>         "params": [],+>         "path": "/api/v2/users",+>         "request_body": null,+>         "request_headers": [],+>         "response": "[User]",+>         "response_headers": []+>     },+>     {+>         "auths": [],+>         "method": "POST",+>         "params": [],+>         "path": "/api/v2/user",+>         "request_body": "UserData",+>         "request_headers": [],+>         "response": "UserId",+>         "response_headers": []+>     }+> ]+>+> ghci> BL.putStrLn . encodePretty $ getRoutes @(NamedRoutes RefactoredAPI)+> [+>     {+>         "auths": [],+>         "method": "GET",+>         "params": [],+>         "path": "/api/v2/users",+>         "request_body": null,+>         "request_headers": [],+>         "response": "[User]",+>         "response_headers": []+>     },+>     {+>         "auths": [],+>         "method": "POST",+>         "params": [],+>         "path": "/user",              -- oops!+>         "request_body": "UserData",+>         "request_headers": [],+>         "response": "UserId",+>         "response_headers": []+>     }+> ]+-}+class HasRoutes api where+  -- | Type-level list of API routes for the given API.+  --+  -- Since @TypeApplications@ is becoming pervasive, we forego @Proxy@ here in favour+  -- of @getRoutes \@API@.+  getRoutes :: [Route]++-- | Get all the routes of an API and print them to stdout. See 'renderRoute' for examples.+printRoutes :: forall api. HasRoutes api => IO ()+printRoutes = traverse_ printRoute $ getRoutes @api+  where+    printRoute = T.putStrLn . renderRoute++{- | Same as 'printRoutes`, but encode the t'Routes' as JSON before printing to stdout.+For an even prettier version, see 'printRoutesJSONPretty'.+-}+printRoutesJSON :: forall api. HasRoutes api => IO ()+printRoutesJSON =+  T.putStrLn+    . TL.toStrict+    . TLE.decodeUtf8+    . encode+    . Routes+    $ getRoutes @api++-- | Pretty-encode the t'Routes' as JSON before printing to stdout.+printRoutesJSONPretty :: forall api. HasRoutes api => IO ()+printRoutesJSONPretty =+  T.putStrLn+    . TL.toStrict+    . TLE.decodeUtf8+    . encodePretty+    . Routes+    $ getRoutes @api++instance HasRoutes EmptyAPI where+  getRoutes = mempty++instance+  ReflectMethod (method :: StdMethod) =>+  HasRoutes (NoContentVerb method)+  where+  getRoutes = pure $ defRoute method+    where+      method = reflectMethod $ Proxy @method++instance+  {-# OVERLAPPABLE #-}+  (ReflectMethod (method :: StdMethod), Typeable a) =>+  HasRoutes (Verb method status ctypes a)+  where+  getRoutes =+    pure $+      defRoute method+        & routeResponse .~ response+    where+      method = reflectMethod $ Proxy @method+      response = oneResponse @a++instance+  {-# OVERLAPPING #-}+  ( ReflectMethod (method :: StdMethod)+  , GetHeaderReps hs+  , Typeable a+  ) =>+  HasRoutes (Verb method status ctypes (Headers hs a))+  where+  getRoutes =+    pure $+      defRoute method+        & routeResponse .~ response+    where+      method = reflectMethod $ Proxy @method+      response = oneResponse @(Headers hs a)++#if MIN_VERSION_servant(0,18,1)+instance+  {-# OVERLAPPING #-}+  (ReflectMethod (method :: StdMethod)) =>+  HasRoutes (UVerb method ctypes '[])+  where+  getRoutes = pure $ defRoute method+    where+      method = reflectMethod $ Proxy @method++instance+  {-# OVERLAPPING #-}+  (ReflectMethod (method :: StdMethod), Typeable a) =>+  HasRoutes (UVerb method ctypes '[a])+  where+  getRoutes =+    pure $+      defRoute method+        & routeResponse .~ response+    where+      method = reflectMethod $ Proxy @method+      response = oneResponse @a++instance+  (ReflectMethod (method :: StdMethod), AllHasResponse as, Unique as) =>+  HasRoutes (UVerb method ctypes as)+  where+  getRoutes =+    pure $+      defRoute method+        & routeResponse .~ response+    where+      method = reflectMethod $ Proxy @method+      response = oneOfResponses @as+#endif++instance (HasRoutes l, HasRoutes r) => HasRoutes (l :<|> r) where+  getRoutes = getRoutes @l <> getRoutes @r++instance (KnownSymbol path, HasRoutes api) => HasRoutes (path :> api) where+  getRoutes = getRoutes @api <&> routePath %~ prependPathPart path+    where+      path = knownSymbolT @path++instance+  (KnownSymbol capture, Typeable a, HasRoutes api) =>+  HasRoutes (Capture' mods capture a :> api)+  where+  getRoutes = getRoutes @api <&> routePath %~ prependCapturePart @a capture+    where+      capture = knownSymbolT @capture++instance+  (KnownSymbol capture, Typeable a, HasRoutes api) =>+  HasRoutes (CaptureAll capture a :> api)+  where+  getRoutes = getRoutes @api <&> routePath %~ prependCaptureAllPart @a capture+    where+      capture = knownSymbolT @capture++instance+  (KnownSymbol sym, Typeable (RequiredArgument mods a), HasRoutes api) =>+  HasRoutes (QueryParam' mods sym a :> api)+  where+  getRoutes = getRoutes @api <&> routeParams `add` param+    where+      param = singleParam @sym @(RequiredArgument mods a)++instance+  (KnownSymbol sym, Typeable a, HasRoutes api) =>+  HasRoutes (QueryParams sym a :> api)+  where+  getRoutes = getRoutes @api <&> routeParams `add` param+    where+      param = arrayElemParam @sym @a++#if MIN_VERSION_servant(0,19,0)+instance (HasRoutes (ToServantApi routes)) => HasRoutes (NamedRoutes routes) where+  getRoutes = getRoutes @(ToServantApi routes)+#endif++instance (KnownSymbol sym, HasRoutes api) => HasRoutes (QueryFlag sym :> api) where+  getRoutes = getRoutes @api <&> routeParams `add` param+    where+      param = flagParam @sym++instance (HasRoutes api, Typeable a) => HasRoutes (ReqBody' mods list a :> api) where+  getRoutes = getRoutes @api <&> routeRequestBody <>~ reqBody+    where+      reqBody = oneRequest @a++instance (HasRoutes api) => HasRoutes (Vault :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api) => HasRoutes (HttpVersion :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api, KnownSymbol realm) => HasRoutes (BasicAuth realm usr :> api) where+  getRoutes = getRoutes @api <&> routeAuths `add` auth+    where+      auth = basicAuth @realm++instance (HasRoutes api) => HasRoutes (Description sym :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api) => HasRoutes (Summary sym :> api) where+  getRoutes = getRoutes @api++instance+  (HasRoutes api, KnownSymbol tag) =>+  HasRoutes (AuthProtect (tag :: Symbol) :> api)+  where+  getRoutes = getRoutes @api <&> routeAuths `add` auth+    where+      auth = customAuth @tag++instance+  (HasRoutes api, KnownSymbol sym, Typeable (RequiredArgument mods a)) =>+  HasRoutes (Header' mods sym a :> api)+  where+  getRoutes = getRoutes @api <&> routeRequestHeaders `add` header+    where+      header = mkHeaderRep @sym @(RequiredArgument mods a)++instance (HasRoutes api) => HasRoutes (Fragment v :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api) => HasRoutes (IsSecure :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api) => HasRoutes (RemoteHost :> api) where+  getRoutes = getRoutes @api++instance (HasRoutes api, Typeable a) => HasRoutes (StreamBody' mods framing ct a :> api) where+  getRoutes = getRoutes @api <&> routeRequestBody .~ reqBody+    where+      reqBody = oneRequest @a++instance (HasRoutes api) => HasRoutes (WithNamedContext name subContext api) where+  getRoutes = getRoutes @api++instance+  (ReflectMethod (method :: StdMethod), Typeable a) =>+  HasRoutes (Stream method status framing ctype a)+  where+  getRoutes =+    pure $+      defRoute method+        & routeResponse .~ response+    where+      method = reflectMethod $ Proxy @method+      response = oneResponse @a

@@ -0,0 +1,47 @@+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Auth+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Here we define a very very basic type to represent authentication schemes.+-}+module Servant.API.Routes.Auth+  ( Auth+  , basicAuth+  , customAuth+  )+where++import GHC.TypeLits (KnownSymbol)+import "this" Servant.API.Routes.Internal.Auth+import "this" Servant.API.Routes.Utils++{- | Create a term-level representation of a \"Basic" authentication scheme.++For example:++> ghci> toJSON $ basicAuth @"user"+> String "Basic user"+-}+basicAuth ::+  forall realm.+  KnownSymbol realm =>+  Auth+basicAuth = Basic $ knownSymbolT @realm++{- | Create a term-level representation of a \"Custom" authentication scheme, i.e. one that+corresponds to Servant's 'Servant.API.AuthProtect' combinator.++For example:++> ghci> toJSON $ customAuth @"OnlyAdminUsers"+> String "OnlyAdminUsers"+-}+customAuth ::+  forall tag.+  KnownSymbol tag =>+  Auth+customAuth = Custom $ knownSymbolT @tag

@@ -0,0 +1,16 @@+{- |+Module      : Servant.API.Routes.Header+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Simple representation of HTTP headers.+-}+module Servant.API.Routes.Header+  ( HeaderRep+  , GetHeaderReps (..)+  , mkHeaderRep+  )+where++import "this" Servant.API.Routes.Internal.Header

@@ -0,0 +1,33 @@+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Auth+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Auth+  ( Auth (..)+  )+where++import Data.Aeson+import qualified Data.Text as T++{- | There are 2 variants:++- \"Basic" authentication: corresponds to the 'Servant.API.BasicAuth' type. Construct with 'Servant.API.Routes.Auth.basicAuth'.+- \"Custom" authentication: corresponds to the 'Servant.API.AuthProtect' type. Construct with 'Servant.API.Routes.Auth.customAuth'.+-}+data Auth+  = Basic T.Text+  | Custom T.Text+  deriving (Show, Eq, Ord)++instance ToJSON Auth where+  toJSON =+    toJSON @T.Text . \case+      Basic realm -> "Basic " <> realm+      Custom tag -> tag

@@ -0,0 +1,72 @@+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Header+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Header+  ( HeaderRep (..)+  , mkHeaderRep+  , GetHeaderReps (..)+  )+where++import Data.Aeson+import Data.Kind (Type)+import Data.Text+import Data.Typeable+import GHC.TypeLits+import Servant.API+import "this" Servant.API.Routes.Utils++-- | Convenience function to construct a 'HeaderRep' from @sym :: 'Symbol'@ and @a :: Type'@.+mkHeaderRep ::+  forall sym a.+  (KnownSymbol sym, Typeable a) =>+  HeaderRep+mkHeaderRep =+  HeaderRep+    { _hName = knownSymbolT @sym+    , _hType = typeRepOf @a+    }++{- | Simple term-level representation of a 'Servant.API.Header.Header'.++A type-level @'Servant.API.Header.Header' (sym :: 'GHC.TypeLits.Symbol') typ@ should correspond to+@'HeaderRep' { _hName = str, _hType =  typRep }@, where @str@ is the term-level equivalent+of @sym@ and @typRep@ is the term-level representation of @typ@.+-}+data HeaderRep = HeaderRep+  { _hName :: Text+  , _hType :: TypeRep+  }+  deriving (Show, Eq, Ord)++instance ToJSON HeaderRep where+  toJSON HeaderRep {..} =+    object+      [ "name" .= _hName+      , "type" .= typeRepToJSON _hType+      ]++{- | Utility class to let us get a value-level list of 'HeaderRep's from a+type-level list of 'Servant.API.Header.Header's. See the implementation of+@'Servant.API.Route.HasRoutes' ('Verb' method status ctypes ('Headers' hs a))@ for an example.+-}+class GetHeaderReps (hs :: [Type]) where+  getHeaderReps :: [HeaderRep]++instance GetHeaderReps '[] where+  getHeaderReps = []++instance+  (GetHeaderReps rest, KnownSymbol h, Typeable v) =>+  GetHeaderReps (Header h v ': rest)+  where+  getHeaderReps = header : getHeaderReps @rest+    where+      header = mkHeaderRep @h @v

@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveAnyClass #-}++{- |+Module      : Servant.API.Routes.Internal.Param+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Param+  ( Param (..)+  )+where++import Data.Aeson+import Data.Function (on)+import GHC.Generics+import qualified Servant.Links as S++{- | Newtype wrapper around servant's 'S.Param' so we can define a sensible+'Eq' instance for it.+-}+newtype Param = Param+  { unParam :: S.Param+  }+  deriving (Show) via S.Param++instance Eq Param where+  (==) = eq `on` unParam+    where+      S.SingleParam name1 rep1 `eq` S.SingleParam name2 rep2 =+        name1 == name2 && rep1 == rep2+      S.ArrayElemParam name1 rep1 `eq` S.ArrayElemParam name2 rep2 =+        name1 == name2 && rep1 == rep2+      S.FlagParam name1 `eq` S.FlagParam name2 =+        name1 == name2+      _ `eq` _ = False++instance Ord Param where+  compare = comp `on` unParam+    where+      S.SingleParam name1 rep1 `comp` S.SingleParam name2 rep2 =+        name1 `compare` name2 <> rep1 `compare` rep2+      S.ArrayElemParam name1 rep1 `comp` S.ArrayElemParam name2 rep2 =+        name1 `compare` name2 <> rep1 `compare` rep2+      S.FlagParam name1 `comp` S.FlagParam name2 =+        name1 `compare` name2+      S.SingleParam {} `comp` _ = LT+      _ `comp` S.SingleParam {} = LT+      S.ArrayElemParam {} `comp` _ = LT+      _ `comp` S.ArrayElemParam {} = LT++data ParamType+  = SingleParam+  | ArrayElemParam+  | FlagParam+  deriving (Show, Eq, Enum, Bounded, Generic)+  deriving (ToJSON)++instance ToJSON Param where+  toJSON (Param p) =+    object $ case p of+      S.SingleParam name rep ->+        withType SingleParam ["name" .= name, "param_type" .= rep]+      S.ArrayElemParam name rep ->+        withType ArrayElemParam ["name" .= name, "param_type" .= rep]+      S.FlagParam name ->+        withType FlagParam ["name" .= name]+    where+      withType t ps = ("type" .= t) : ps

@@ -0,0 +1,65 @@+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Path+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Path+  ( Path (..)+  , renderPath+  , pathSeparator+  , PathPart (..)+  )+where++import Data.Aeson+import Data.String+import qualified Data.Text as T+import Data.Typeable++-- | A segment of an API path (between @"/"@s).+data PathPart+  = -- | Just a plain path part, e.g. @"api/"@.+    StringPart T.Text+  | -- | Capture a path part as a variable.+    CapturePart T.Text TypeRep+  | -- | Capture all path part as a list of variables.+    CaptureAllPart T.Text TypeRep+  deriving (Eq, Ord)++instance IsString PathPart where+  fromString = StringPart . T.pack++instance Show PathPart where+  show = T.unpack . renderPathPart++-- | Pretty-print a path part.+renderPathPart :: PathPart -> T.Text+renderPathPart = \case+  StringPart t -> t+  CapturePart _ typ -> "<" <> T.pack (show typ) <> ">"+  CaptureAllPart _ typ -> "<[" <> T.pack (show typ) <> "]>"++-- | Standard path separator @"/"@.+pathSeparator :: T.Text+pathSeparator = "/"++-- | Simple representation of a URL path.+newtype Path = Path+  { unPath :: [PathPart]+  }+  deriving (Eq, Ord) via [PathPart]++instance Show Path where+  show = T.unpack . renderPath++instance ToJSON Path where+  toJSON = toJSON . renderPath++-- | Pretty-print a path, including the leading @/@.+renderPath :: Path -> T.Text+renderPath = (pathSeparator <>) . T.intercalate pathSeparator . fmap renderPathPart . unPath

@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Request+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Request+  ( Request (..)+  , unRequest+  , AllTypeable (..)+  )+where++import Data.Aeson+import Data.Function (on)+import Data.Kind (Type)+import Data.List (nub, sort)+import Data.Typeable+import Lens.Micro.TH+import "this" Servant.API.Routes.Internal.Some as S+import "this" Servant.API.Routes.Utils++{- | A representation of the request /body/(s) that a Servant endpoint expects.++Under the hood, 'Request' is a @'Some' 'TypeRep'@.+This allows for the possibility that an endpoint might expect the request body+to parse as several different types (multiple 'Servant.API.ReqBody''s).++Note that this type doesn't include any information about the headers that an+endpoint expects, since those are independent of the request body.+-}+newtype Request = Request {_unRequest :: Some TypeRep}+  deriving (Show) via Some TypeRep++makeLenses ''Request++instance ToJSON Request where+  toJSON = someToJSONAs typeRepToJSON "all_of" . _unRequest++instance Eq Request where+  (==) = eqSome ((==) `on` (sort . nub)) `on` _unRequest++instance Semigroup Request where+  Request b1 <> Request b2 = Request (appendSome (:) (flip (:)) b1 b2)++instance Monoid Request where+  mempty = Request S.None++{- | This class does 2 things:++- It lets us get a term-level list of 'TypeRep's from a type-level list of types, all of+  which have 'Typeable' instances.+- More impressively, its instances enforce that 'typeReps' will only type-check for type-level+  lists of length 2 or more. This is because 'AllTypeable' will only ever be used by+  'Servant.API.Routes.Request.allOfRequests', which is the only way to construct a+  'Many' @'Request' and thus lets us enforce the invariant that its list arguments will always+  have more than 1 element. This lets us make sure that there's only ever one way to represent a list of+  'TypeRep's using 'Request'.++  Of course, someone might import this Internal module and define a @'Typeable' a => 'AllTypeable' '[a]@+  instance. Don't do that.+-}+class AllTypeable (as :: [Type]) where+  typeReps :: [TypeRep]++instance (Typeable a, Typeable b) => AllTypeable '[a, b] where+  typeReps = [typeRepOf @a, typeRepOf @b]++instance (Typeable a, AllTypeable (b ': c ': as)) => AllTypeable (a ': b ': c ': as) where+  typeReps = typeRepOf @a : typeReps @(b ': c ': as)

@@ -0,0 +1,122 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Response+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Response+  ( Responses (..)+  , unResponses+  , Response (..)+  , responseType+  , responseHeaders+  , HasResponse (..)+  , AllHasResponse (..)+  )+where++import Data.Aeson+import Data.Function (on)+import Data.Kind (Type)+import Data.List (nub, sort)+import qualified Data.Set as Set+import Data.Typeable+import Lens.Micro+import Lens.Micro.TH+import Servant.API hiding (getResponse)+import "this" Servant.API.Routes.Internal.Header+import "this" Servant.API.Routes.Internal.Some as S+import "this" Servant.API.Routes.Utils++{- | A representation of /one/ possible response that a Servant endpoint+can return.++Currently, the only situation in which multiple 'Response's can be returned+is using the 'UVerb' combinator. This bundles response /types/ together with+response 'Servant.API.Header.Header's, so we do the same here.+-}+data Response = Response+  { _responseType :: TypeRep+  , _responseHeaders :: Set.Set HeaderRep+  }+  deriving (Show, Eq, Ord)++makeLenses ''Response++instance ToJSON Response where+  toJSON Response {..} =+    object+      [ "type" .= typeRepToJSON _responseType+      , "headers" .= _responseHeaders+      ]++{- | Get a term-level response from a type-level argument. This encodes the argument(s)+of a 'Verb' or 'UVerb'.++Similar to 'Typeable', but also get the response 'Servant.API.Header.Header's.+-}+class HasResponse a where+  getResponse :: Response++instance {-# OVERLAPPABLE #-} Typeable a => HasResponse a where+  getResponse = Response (typeRepOf @a) mempty++instance {-# OVERLAPPING #-} (HasResponse a, GetHeaderReps hs) => HasResponse (Headers hs a) where+  getResponse =+    getResponse @a+      & responseHeaders <>~ Set.fromList (getHeaderReps @hs)++{- | Witness that all members of a type-level list are instances of 'HasResponse'.++This class does 2 things:++- It lets us get a term-level list of 'Response's from a type-level list of types, all of+  which have 'HasResponse' instances.+- More impressively, its instances enforce that 'getResponses' will only type-check for type-level+  lists of length 2 or more. This is because 'AllHasResponse' will only ever be used by+  'Servant.API.Routes.Response.oneOfResponses', which is the only way to construct a+  'Many' @'Response' and thus lets us enforce the invariant that its list arguments will always+  have more than 1 element. This lets us make sure that there's only ever one way to represent a list of+  'Response's using 'Responses'.++  Of course, someone might import this Internal module and define a @'HasResponse' a => 'AllHasResponse' '[a]@+  instance. Don't do that.+-}+class AllHasResponse (as :: [Type]) where+  getResponses :: [Response]++instance (HasResponse a, HasResponse b) => AllHasResponse '[a, b] where+  getResponses = [getResponse @a, getResponse @b]++instance (HasResponse a, AllHasResponse (b ': c ': as)) => AllHasResponse (a ': b ': c ': as) where+  getResponses = getResponse @a : getResponses @(b ': c ': as)++{- | A representation of the response(s) that a Servant endpoint can return.++Under the hood, 'Responses' is a @'Some' 'Response'@.+This allows for the possibility that an endpoint might return one of several+responses, via 'UVerb'.++Note that a 'Response' consists of a return body type, /as well as/ the return headers.+-}+newtype Responses = Responses {_unResponses :: Some Response}+  deriving (Show) via Some Response++makeLenses ''Responses++instance Eq Responses where+  (==) = eqSome ((==) `on` (sort . nub)) `on` _unResponses++instance Semigroup Responses where+  Responses b1 <> Responses b2 = Responses (appendSome (:) (flip (:)) b1 b2)++instance Monoid Responses where+  mempty = Responses S.None++instance ToJSON Responses where+  toJSON = someToJSONAs toJSON "one_of" . _unResponses

@@ -0,0 +1,66 @@+{-# LANGUAGE TemplateHaskell #-}++{- |+Module      : Servant.API.Routes.Internal.Route+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.+-}+module Servant.API.Routes.Internal.Route+  ( -- * API routes+    Route (..)++    -- * Optics #optics#+  , routeMethod+  , routePath+  , routeParams+  , routeRequestHeaders+  , routeRequestBody+  , routeResponse+  , routeAuths+  )+where++import Data.Aeson+import Data.Function (on)+import qualified Data.Set as Set+import qualified Data.Text.Encoding as TE+import Lens.Micro.TH+import Network.HTTP.Types.Method (Method)+import "this" Servant.API.Routes.Auth+import "this" Servant.API.Routes.Header+import "this" Servant.API.Routes.Internal.Request+import "this" Servant.API.Routes.Internal.Response+import "this" Servant.API.Routes.Param+import "this" Servant.API.Routes.Path++-- | A simple representation of a single endpoint of an API.+data Route = Route+  { _routeMethod :: Method+  , _routePath :: Path+  , _routeParams :: Set.Set Param+  , _routeRequestHeaders :: Set.Set HeaderRep+  , _routeRequestBody :: Request+  , _routeResponse :: Responses+  , _routeAuths :: Set.Set Auth+  }+  deriving (Show, Eq)++makeLenses ''Route++instance Ord Route where+  compare = compare `on` \Route {..} -> (_routePath, _routeMethod)++instance ToJSON Route where+  toJSON Route {..} =+    object+      [ "method" .= TE.decodeUtf8 _routeMethod+      , "path" .= _routePath+      , "params" .= _routeParams+      , "request_headers" .= _routeRequestHeaders+      , "request_body" .= _routeRequestBody+      , "response" .= _routeResponse+      , "auths" .= _routeAuths+      ]

@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveTraversable #-}+{-# OPTIONS_HADDOCK not-home #-}++{- |+Module      : Servant.API.Routes.Internal.Some+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Internal module, subject to change.++For both requests and responses, we want to represent three situations, depending on the number+of /X/ present: 0, 1, or many.++For example, if multiple 'Servant.API.ReqBody''s are chained together with @:>@, the resulting+type's @HasServer@ instance would try to parse the request body as all of the relevant types. In this+case the 'Servant.API.Routes.Internal.Route._routeRequestBody' field needs to be able to contain several+'Data.Typeable.TypeRep's as a conjunction (AND).++On the other hand, the 'Servant.API.UVerb' combinator lets us represent an endpoint that may return one of+several types: hence the 'Servant.API.Routes.Internal.Route._routeResponse' field needs to be able to contain+several possible responses as a disjunction (OR).++The 'Some' type lets us represent both of these situations.++However we need to abstract over the type contained in 'Some', since we need to represent different+data in those 2 different situations, because of the way that Servant represents them:++  - for requests, different 'Servant.API.ReqBody's and 'Servant.API.Header.Header's are independent.+    Therefore in 'Servant.API.Routes.Route.Route', for requests we have+    @'Servant.API.Routes.Internal.Route._routeRequestHeaders' :: 'Servant.API.Routes.Header.HeaderRep'@ and+    @'Servant.API.Routes.Internal.Route._routeRequestBody' ~ 'Some' 'Data.Typeable.TypeRep'@.+  - for responses, multiple response options are represented using 'Servant.API.UVerb', which bundles response+    types and headers together. Therefore for responses we have just one field,+    @'Servant.API.Routes.Internal.Route._routeResponse' ~ 'Some' ('Data.Typeable.TypeRep', ['Servant.API.Routes.Header.HeaderRep'])@.+-}+module Servant.API.Routes.Internal.Some+  ( Some (..)+  , toList+  , fromList+  , eqSome+  , appendSome+  , someToJSONAs+  )+where++import Data.Aeson+import qualified Data.Aeson.Key as AK (fromText)+import qualified Data.Foldable as Fold+import qualified Data.Text as T++-- | Simple ADT which codifies whether a list contains 0, 1, or many elements.+data Some a+  = None+  | One a+  | -- | Invariant: list needs to have length > 1+    --+    -- Whether or not order is important is left up to the user. Therefore we define no instances of+    -- 'Eq', 'Ord', 'Semigroup' or any other class that would involve comparing or combining this list.+    Many [a]+  deriving (Show, Functor, Foldable, Traversable)++{- | Compare 2 'Some's for equality, given a way to compare lists in the 'Many' constructor.++Use this to implement `Eq` instances for newtypes around 'Some'.+-}+eqSome :: forall a. Eq a => ([a] -> [a] -> Bool) -> Some a -> Some a -> Bool+eqSome eqList = eq+  where+    None `eq` None = True+    One t1 `eq` One t2 = t1 == t2+    Many ts1 `eq` Many ts2 = ts1 `eqList` ts2+    _ `eq` _ = False++{- | Combine 2 'Some's, given a way to combine single elements with lists in the+@'Servant.API.Routes.Internal.Some.One' <> 'Many'@ cases.++Use this to implement `Semigroup` instances for newtypes around 'Some'.+-}+appendSome ::+  forall a.+  (a -> [a] -> [a]) ->+  ([a] -> a -> [a]) ->+  Some a ->+  Some a ->+  Some a+appendSome cons' snoc' = app+  where+    None `app` x = x+    x `app` None = x+    One t1 `app` One t2 = Many [t1, t2]+    One t `app` Many ts = Many (t `cons'` ts)+    Many ts `app` One t = Many (ts `snoc'` t)+    Many ts1 `app` Many ts2 = Many (ts1 <> ts2)++-- | Convert a 'Some' to a list. Inverse of 'fromList'.+toList :: Some a -> [a]+toList = Fold.toList++{- | Convert a list of @a@s to a 'Some'. Inverse of 'toList'.++This maintains the invariant that the argument of 'Many' has to be of length > 1.+-}+fromList :: [a] -> Some a+fromList = \case+  [] -> None+  [tRep] -> One tRep+  tReps -> Many tReps++{- | Represent a 'Some' as a JSON 'Value'.++Use this to implement `ToJSON` instances for newtypes around 'Some'.++This choice of representation is opinionated, and some may disagree.++Given a function @f@ to convert an @a@ to JSON, and a @label@:++@+'None' -> null+'Servant.API.Routes.Internal.Some.One' a -> f a+'Many' list -> { label: map f list }+@+-}+someToJSONAs :: (a -> Value) -> T.Text -> Some a -> Value+someToJSONAs aToJSON lbl = \case+  None -> Null+  One tRep -> aToJSON tRep+  Many tReps ->+    object [AK.fromText lbl .= fmap aToJSON tReps]

@@ -0,0 +1,50 @@+{- |+Module      : Servant.API.Routes.Param+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Simple representation of HTTP query params+-}+module Servant.API.Routes.Param+  ( Param+  , singleParam+  , arrayElemParam+  , flagParam+  , renderParam+  )+where++import qualified Data.Text as T+import Data.Typeable+import GHC.TypeLits+import "this" Servant.API.Routes.Internal.Param+import "this" Servant.API.Routes.Utils+import qualified Servant.Links as S++-- | Create a 'S.SingleParam' from a 'Symbol' and a 'TypeRep' via 'Typeable'.+singleParam :: forall s a. (KnownSymbol s, Typeable a) => Param+singleParam = Param (S.SingleParam name rep)+  where+    rep = showTypeRep @a+    name = symbolVal $ Proxy @s++-- | Create an 'S.ArrayParam' from a 'Symbol' and a 'TypeRep' via 'Typeable'.+arrayElemParam :: forall s a. (KnownSymbol s, Typeable a) => Param+arrayElemParam = Param (S.ArrayElemParam name rep)+  where+    rep = showTypeRep @a+    name = symbolVal $ Proxy @s++-- | Create a 'S.FlagParam' from a 'Symbol'.+flagParam :: forall s. (KnownSymbol s) => Param+flagParam = Param (S.FlagParam name)+  where+    name = symbolVal $ Proxy @s++-- | Pretty-print a 'Param'. Used by 'Servant.API.Routes.renderRoute'.+renderParam :: Param -> T.Text+renderParam (Param param) = case param of+  S.SingleParam var typ -> T.pack var <> "=<" <> typ <> ">"+  S.ArrayElemParam var typ -> T.pack var <> "=<[" <> typ <> "]>"+  S.FlagParam var -> T.pack var

@@ -0,0 +1,68 @@+{- |+Module      : Servant.API.Routes.Path+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Simple representation of URL paths.+-}+module Servant.API.Routes.Path+  ( Path+  , prependPathPart+  , prependCapturePart+  , prependCaptureAllPart+  , renderPath+  , rootPath+  )+where++import qualified Data.Text as T+import Data.Typeable+import "this" Servant.API.Routes.Internal.Path+import "this" Servant.API.Routes.Utils++-- | @"/"@+rootPath :: Path+rootPath = Path []++{- | Prepend a simple text path part to an API path.++For example, @prependPathPart "api"@ will transform @\/v2\/users@ to @\/api\/v2\/users@.+-}+prependPathPart :: T.Text -> Path -> Path+prependPathPart part (Path parts) =+  Path (splitParts <> parts)+  where+    splitParts = fmap StringPart . filter (not . T.null) $ T.splitOn pathSeparator part++{- | Prepend a capture path part of a given type to an API path.+Equivalent to @'Servant.API.Capture' name a :>@.++For example, @prependCapturePart \@Int "id"@ will transform @\/detail@ to @\/\<Int>\/detail@.+-}+prependCapturePart ::+  forall a.+  Typeable a =>+  T.Text ->+  Path ->+  Path+prependCapturePart name (Path parts) =+  Path (capture : parts)+  where+    capture = CapturePart name $ typeRepOf @a++{- | Prepend a capture-all path part of a given type to an API path.+Equivalent to @'Servant.API.CaptureAll' name a :>@.++For example, @prependCaptureAllPart \@Int "id"@ will transform @\/detail@ to @\/\<[Int]>\/detail@.+-}+prependCaptureAllPart ::+  forall a.+  Typeable a =>+  T.Text ->+  Path ->+  Path+prependCaptureAllPart name (Path parts) =+  Path (capture : parts)+  where+    capture = CaptureAllPart name $ typeRepOf @a

@@ -0,0 +1,49 @@+{- |+Module      : Servant.API.Routes.Request+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Term-level representation of the request bodies that Servant endpoints expect.+-}+module Servant.API.Routes.Request+  ( Request+  , unRequest+  , noRequest+  , oneRequest+  , allOfRequests+  , requests+  )+where++import Data.Typeable+import Lens.Micro+import "this" Servant.API.Routes.Internal.Request+import "this" Servant.API.Routes.Internal.Some+import "this" Servant.API.Routes.Utils++-- | The endpoint doesn't expect a request body.+noRequest :: Request+noRequest = Request None++{- | The request body can only be of one type. Equivalent to a single+@'Servant.API.ReqBody' _ a@.+-}+oneRequest ::+  forall a.+  Typeable a =>+  Request+oneRequest = Request . One $ typeRepOf @a++{- | The endpoint expects the request body to be parsed as multiple (>1) types.+Equivalent to multiple 'Servant.API.ReqBody's chained with @:>@.+-}+allOfRequests ::+  forall as.+  AllTypeable as =>+  Request+allOfRequests = Request . Many $ typeReps @as++-- | Convenience optic to traverse over all the 'TypeRep's within a 'Request'.+requests :: Traversal' Request TypeRep+requests = unRequest . traversed

@@ -0,0 +1,50 @@+{- |+Module      : Servant.API.Routes.Response+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Term-level representation of the responses that Servant endpoints can return.+-}+module Servant.API.Routes.Response+  ( Responses+  , unResponses+  , noResponse+  , oneResponse+  , oneOfResponses+  , Response+  , responseType+  , responseHeaders+  , responses+  , HasResponse (..)+  , AllHasResponse (..)+  )+where++import Lens.Micro+import "this" Servant.API.Routes.Internal.Response+import "this" Servant.API.Routes.Internal.Some++-- | The endpoint will not return a response.+noResponse :: Responses+noResponse = Responses None++-- | There is only one possible response. Equivalent to a single @'Servant.API.ReqBody' _ a@.+oneResponse ::+  forall a.+  HasResponse a =>+  Responses+oneResponse = Responses . One $ getResponse @a++{- | The endpoint may return one of multiple multiple (>1) responses.+Equivalent to a 'Servant.API.UVerb's with more than one type.+-}+oneOfResponses ::+  forall as.+  AllHasResponse as =>+  Responses+oneOfResponses = Responses . Many $ getResponses @as++-- | Convenience optic to traverse over all the 'Response's within a 'Responses'.+responses :: Traversal' Responses Response+responses = unResponses . traversed

@@ -0,0 +1,87 @@+{- |+Module      : Servant.API.Routes.Route+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Simple term-level representation of Servant API endpoints.+-}+module Servant.API.Routes.Route+  ( -- * API routes++    -- | The 'Route' type is not sophisticated, and its internals are hidden.+    -- Create 'Route's using 'Servant.API.Routes.Route.defRoute', and update its fields+    -- using the provided [lenses](#g:optics).+    Route+  , defRoute+  , renderRoute++    -- * Optics #optics#+  , routeMethod+  , routePath+  , routeParams+  , routeRequestHeaders+  , routeRequestBody+  , routeResponse+  , routeAuths+  , add+  )+where++import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Lens.Micro+import Network.HTTP.Types.Method (Method)+import "this" Servant.API.Routes.Internal.Route+import "this" Servant.API.Routes.Param+import "this" Servant.API.Routes.Path+import "this" Servant.API.Routes.Request+import "this" Servant.API.Routes.Response++{- | Given a REST 'Method', create a default 'Route': root path (@"/"@) with no params,+headers, body, auths, or response.+-}+defRoute :: Method -> Route+defRoute method =+  Route+    { _routeMethod = method+    , _routePath = rootPath+    , _routeParams = Set.empty+    , _routeRequestHeaders = mempty+    , _routeRequestBody = noRequest+    , _routeResponse = noResponse+    , _routeAuths = mempty+    }++{- | Pretty-print a 'Route'. Note that the output is minimal and doesn't contain all the information+contained in a 'Route'. For full output, use the 'Data.Aeson.ToJSON' instance.++> ghci> renderRoute $ defRoute \"POST\"+> "POST /"+> ghci> :{+> ghci| renderRoute $+> ghci|   defRoute \"POST\"+> ghci|     & routePath %~ prependPathPart "api/v2"+> ghci|     & routeParams .~ [singleParam @"p1" @T.Text, flagParam @"flag", arrayElemParam @"p2s" @(Maybe Int)]+> ghci| :}+> "POST /api/v2?p1=<Text>&flag&p2s=<[Maybe Int]>"+-}+renderRoute :: Route -> T.Text+renderRoute Route {..} =+  mconcat+    [ method+    , " "+    , path+    , params+    ]+  where+    method = TE.decodeUtf8 _routeMethod+    path = renderPath _routePath+    params =+      if null _routeParams+        then ""+        else "?" <> T.intercalate "&" (renderParam <$> Set.toList _routeParams)++add :: Ord a => ASetter s t (Set.Set a) (Set.Set a) -> a -> s -> t+add setter = over setter . Set.insert

@@ -0,0 +1,37 @@+{- |+Module      : Servant.API.Routes.Utils+Copyright   : (c) Frederick Pringle, 2025+License     : BSD-3-Clause+Maintainer  : freddyjepringle@gmail.com++Common useful functions.+-}+module Servant.API.Routes.Utils+  ( knownSymbolT+  , typeRepToJSON+  , showTypeRep+  , typeRepOf+  )+where++import Data.Aeson+import Data.Kind+import qualified Data.Text as T+import Data.Typeable+import GHC.TypeLits++-- | Get the term-level equivalent of a 'Symbol' as a 'T.Text'.+knownSymbolT :: forall name. KnownSymbol name => T.Text+knownSymbolT = T.pack . symbolVal $ Proxy @name++-- | Convert a 'TypeRep' to a JSON 'Value' via its 'Show' instance.+typeRepToJSON :: TypeRep -> Value+typeRepToJSON = toJSON . show @TypeRep++-- | Get the 'TypeRep' of a 'Typeable' type without having to mess around with 'Proxy'.+typeRepOf :: forall a. Typeable a => TypeRep+typeRepOf = typeRep $ Proxy @a++-- | Get the 'TypeRep' of a 'Typeable' type as a 'T.Text'.+showTypeRep :: forall (a :: Type). Typeable a => T.Text+showTypeRep = T.pack . show $ typeRepOf @a

@@ -0,0 +1,32 @@+module Servant.API.Routes.HeaderSpec+  ( spec+  , sampleReps+  )+where++import Servant.API (Header)+import Servant.API.Routes.Header+import Servant.API.Routes.Internal.Header+import Servant.API.Routes.Util+import Test.Hspec as H++spec :: Spec+spec = do+  describe "mkHeaderRep" $ do+    it "should work" $ do+      mkHeaderRep @"sym" @Int `shouldBe` HeaderRep "sym" intTypeRep++  describe "GetheaderReps" $ do+    it "should return an empty list for an empty type-level list" $+      getHeaderReps @'[] `shouldBe` []+    it "should recurse properly" $+      sampleReps `shouldBe` HeaderRep "h1" intTypeRep : getHeaderReps @'[H2, H3]++type H1 = Header "h1" Int++type H2 = Header "h2" Char++type H3 = Header "h3" [Integer]++sampleReps :: [HeaderRep]+sampleReps = getHeaderReps @'[H1, H2, H3]

@@ -0,0 +1,25 @@+module Servant.API.Routes.ParamSpec where++import qualified Data.Text as T+import Servant.API.Routes.Param+import Test.Hspec as H++sing, arrayElem, flag :: Param+sing = singleParam @"sing_sym" @Int+arrayElem = arrayElemParam @"array_sym" @Int+flag = flagParam @"flag_sym"++singExpected, arrayElemExpected, flagExpected :: T.Text+singExpected = "sing_sym=<Int>"+arrayElemExpected = "array_sym=<[Int]>"+flagExpected = "flag_sym"++spec :: Spec+spec = do+  describe "renderParam" $ do+    it "should render singleParam correctly" $ do+      renderParam sing `shouldBe` singExpected+    it "should render arrayElemParam correctly" $ do+      renderParam arrayElem `shouldBe` arrayElemExpected+    it "should render flagParam correctly" $ do+      renderParam flag `shouldBe` flagExpected

@@ -0,0 +1,94 @@+module Servant.API.Routes.PathSpec where++import qualified Data.Text as T+import Data.Typeable+import Servant.API.Routes.Internal.Path+import Servant.API.Routes.Path+import Test.Hspec as H+import Test.Hspec.QuickCheck as H+import Test.QuickCheck as Q++genAlphaText :: Q.Gen T.Text+genAlphaText =+  T.pack <$> do+    first' <- alnum+    rest <- Q.listOf alnumOrOther+    last' <- alnum+    pure $ first' : rest <> [last']+  where+    alnumChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']+    alnum = Q.elements alnumChars+    alnumOrOther = Q.elements $ alnumChars <> "-_"++shrinkText :: T.Text -> [T.Text]+shrinkText = fmap T.pack . filter (not . null) . Q.shrinkList (const []) . T.unpack++genStringPart :: Q.Gen T.Text+genStringPart = genAlphaText++genTypeRep :: Q.Gen TypeRep+genTypeRep =+  Q.elements+    [ typeRep (Proxy @Int)+    , typeRep (Proxy @String)+    , typeRep (Proxy @())+    , typeRep (Proxy @[Int])+    ]++genPathPart :: Q.Gen PathPart+genPathPart =+  Q.frequency+    [ (6, StringPart <$> genStringPart)+    , (3, CapturePart <$> genStringPart <*> genTypeRep)+    , (1, CaptureAllPart <$> genStringPart <*> genTypeRep)+    ]++genStringParts :: Q.Gen T.Text+genStringParts = unSplit <$> Q.listOf genStringPart++shrinkStringPart :: T.Text -> [T.Text]+shrinkStringPart = shrinkText++shrinkStringParts :: T.Text -> [T.Text]+shrinkStringParts = fmap unSplit . Q.shrinkList shrinkStringPart . T.splitOn "/"++unSplit :: [T.Text] -> T.Text+unSplit = mappend pathSeparator . T.intercalate pathSeparator++shrinkPathPart :: PathPart -> [PathPart]+shrinkPathPart = \case+  StringPart str -> StringPart <$> shrinkStringPart str+  CapturePart name tRep -> [CapturePart name' tRep | name' <- shrinkStringPart name]+  CaptureAllPart name tRep -> [CaptureAllPart name' tRep | name' <- shrinkStringPart name]++normalise :: T.Text -> T.Text+normalise =+  unSplit+    . filter (not . T.null)+    . T.splitOn pathSeparator++instance Q.Arbitrary Path where+  arbitrary = Path <$> Q.listOf genPathPart+  shrink = fmap Path . Q.shrinkList shrinkPathPart . unPath++testPrep :: T.Text -> Path -> Q.Property+testPrep part path =+  let preped = prependPathPart part path+      lhs = renderPath preped+      rhs = part <> pathSeparator <> renderPath path+  in  normalise lhs === normalise rhs++spec :: Spec+spec = do+  describe "renderPath" $ do+    it "should render the root path correctly" $+      renderPath rootPath `shouldBe` pathSeparator+  describe "prependPathPart" $ do+    H.prop "should correctly prepend a single path part" $+      \(path :: Path) ->+        Q.forAllShrink genStringPart shrinkStringPart $ \part ->+          testPrep part path+    H.prop "should correctly prepend a multi-part path" $+      \(path :: Path) ->+        Q.forAllShrink genStringParts shrinkStringParts $ \part ->+          testPrep part path

@@ -0,0 +1,33 @@+module Servant.API.Routes.RequestSpec+  ( spec+  )+where++import Servant.API.Routes.Internal.Request+import "this" Servant.API.Routes.SomeSpec hiding (spec)+import Servant.API.Routes.Util+import Test.Hspec as H+import Test.Hspec.QuickCheck as H+import Test.QuickCheck as Q++{- hlint ignore "Monoid law, right identity" -}+{- hlint ignore "Monoid law, left identity" -}+{- hlint ignore "Use fold" -}++instance Q.Arbitrary Request where+  arbitrary = Request <$> genSome (Q.elements [intTypeRep, strTypeRep, unitTypeRep])+  shrink = unRequest (shrinkSome (const []))++spec :: Spec+spec = do+  describe "Semigroup/Monoid laws" $ do+    prop "Associativity" $ do+      \(x :: Request, y, z) -> x <> (y <> z) === (x <> y) <> z+    prop "Right identity" $+      \(x :: Request) -> x <> mempty === x+    prop "Left identity" $ do+      \(x :: Request) -> mempty <> x === x+    prop "Concatentation" $ do+      \(xs :: [Request]) -> mconcat xs === foldr (<>) mempty xs+  it "AllTypeable" $ do+    typeReps @'[Int, String] `shouldMatchList` [intTypeRep, strTypeRep]

@@ -0,0 +1,42 @@+module Servant.API.Routes.ResponseSpec+  ( spec+  )+where++import qualified Data.Set as Set+import "this" Servant.API.Routes.HeaderSpec (sampleReps)+import Servant.API.Routes.Internal.Response+import "this" Servant.API.Routes.SomeSpec hiding (spec)+import Servant.API.Routes.Util+import Test.Hspec as H+import Test.Hspec.QuickCheck as H+import Test.QuickCheck as Q++{- hlint ignore "Monoid law, right identity" -}+{- hlint ignore "Monoid law, left identity" -}+{- hlint ignore "Use fold" -}++instance Q.Arbitrary Responses where+  arbitrary = Responses <$> genSome arbitrary+  shrink = unResponses (shrinkSome shrink)++instance Q.Arbitrary Response where+  arbitrary = do+    _responseType <- Q.elements [intTypeRep, strTypeRep, unitTypeRep]+    _responseHeaders <- Set.fromList <$> Q.sublistOf sampleReps+    pure Response {..}+  shrink =+    responseHeaders $+      fmap Set.fromList . Q.shrinkList (const []) . Set.toList++spec :: Spec+spec = do+  describe "Semigroup/Monoid laws" $ do+    prop "Associativity" $ do+      \(x :: Responses, y, z) -> x <> (y <> z) === (x <> y) <> z+    prop "Right identity" $+      \(x :: Responses) -> x <> mempty === x+    prop "Left identity" $ do+      \(x :: Responses) -> mempty <> x === x+    prop "Concatentation" $ do+      \(xs :: [Responses]) -> mconcat xs === foldr (<>) mempty xs

@@ -0,0 +1,76 @@+module Servant.API.Routes.RouteSpec+  ( spec+  )+where++import Data.Function+import qualified Data.Set as Set+import qualified Data.Text as T+import Lens.Micro+import Network.HTTP.Types.Method+import Servant.API.Routes.HeaderSpec hiding (spec)+import Servant.API.Routes.Internal.Auth+import Servant.API.Routes.Internal.Path+import Servant.API.Routes.Internal.Route+import Servant.API.Routes.ParamSpec hiding (spec)+import Servant.API.Routes.PathSpec (genAlphaText, shrinkText)+import Servant.API.Routes.RequestSpec ()+import Servant.API.Routes.ResponseSpec ()+import Servant.API.Routes.Route+import Test.Hspec as H+import Test.QuickCheck as Q++instance Q.Arbitrary Route where+  arbitrary = do+    _routeMethod <- renderStdMethod <$> Q.arbitraryBoundedEnum+    _routePath <- arbitrary+    _routeParams <- Set.fromList <$> Q.sublistOf [sing, arrayElem, flag]+    _routeRequestHeaders <- Set.fromList <$> Q.sublistOf sampleReps+    _routeRequestBody <- arbitrary+    _routeResponse <- arbitrary+    _routeAuths <- Set.fromList <$> Q.listOf genAuths++    pure Route {..}+    where+      genAuths =+        Q.oneof+          [ Basic <$> genAlphaText+          , Custom <$> genAlphaText+          ]++  shrink r =+    routeMethod shrinkMethod r+      <> routePath Q.shrink r+      <> routeParams shrinkSubset r+      <> routeRequestHeaders shrinkSubset r+      <> routeRequestBody Q.shrink r+      <> routeResponse Q.shrink r+      <> routeAuths (shrinkSet shrinkAuth) r+    where+      shrinkMethod = either (const []) (fmap renderStdMethod . Q.shrinkBoundedEnum) . parseMethod+      shrinkSet shr = fmap Set.fromList . Q.shrinkList shr . Set.toList+      shrinkSubset :: Ord a => Set.Set a -> [Set.Set a]+      shrinkSubset = shrinkSet (const [])+      shrinkAuth = \case+        Basic realm -> Basic <$> shrinkText realm+        Custom tag -> Custom <$> shrinkText tag++spec :: Spec+spec = do+  describe "Route" $ do+    describe "renderRoute" $ do+      it "renders default route correctly" $+        renderRoute (defRoute "POST") `shouldBe` "POST " <> pathSeparator+      it "renders path correctly" $+        let route =+              defRoute "GET"+                & routePath .~ Path ["api", "v2"]+            expected = "GET /api/v2"+        in  renderRoute route `shouldBe` expected+      it "renders query params correctly" $+        let route =+              defRoute "PUT"+                & routePath .~ Path ["api", "v2"]+                & routeParams .~ Set.fromList [sing, arrayElem, flag]+            expected = "PUT /api/v2?" <> T.intercalate "&" [singExpected, arrayElemExpected, flagExpected]+        in  renderRoute route `shouldBe` expected

@@ -0,0 +1,57 @@+module Servant.API.Routes.SomeSpec+  ( spec+  , genSome+  , shrinkSome+  )+where++import Servant.API.Routes.Internal.Some as S+import Test.Hspec as H+import Test.Hspec.QuickCheck as H+import Test.QuickCheck as Q++{- hlint ignore "Monoid law, right identity" -}+{- hlint ignore "Monoid law, left identity" -}+{- hlint ignore "Use fold" -}++genSome :: Q.Gen a -> Q.Gen (Some a)+genSome gen =+  Q.frequency+    [ (1, pure S.None)+    , (2, S.One <$> gen)+    , (4, S.Many . unAtLeast2 <$> genAtLeast2 gen)+    ]++shrinkSome :: (a -> [a]) -> Some a -> [Some a]+shrinkSome shr = fmap S.fromList . Q.shrinkList shr . S.toList++instance Q.Arbitrary a => Q.Arbitrary (Some a) where+  arbitrary = genSome arbitrary+  shrink = shrinkSome shrink++newtype AtLeast2 a = AtLeast2 {unAtLeast2 :: [a]}+  deriving (Show, Eq) via [a]++genAtLeast2 :: Q.Gen a -> Q.Gen (AtLeast2 a)+genAtLeast2 gen = do+  a1 <- gen+  a2 <- gen+  as <- Q.listOf gen+  pure . AtLeast2 $ a1 : a2 : as++instance Arbitrary a => Arbitrary (AtLeast2 a) where+  arbitrary = genAtLeast2 arbitrary+  shrink = fmap AtLeast2 . filter ((>= 2) . length) . shrink . unAtLeast2++spec :: Spec+spec = do+  describe "Some a <-> [a]" $ do+    it "None" $ testList @Int []+    prop "oneType" $ \(x :: Int) -> testList [x]+    prop "manyTypes" $ \(AtLeast2 (xs :: [Int])) -> testList xs+  where+    testList :: forall a. (Eq a, Show a) => [a] -> Q.Property+    testList lst =+      let some = S.fromList lst+          lst' = S.toList some+      in  lst === lst'

@@ -0,0 +1,12 @@+module Servant.API.Routes.Util where++import Data.Typeable++intTypeRep :: TypeRep+intTypeRep = typeRep $ Proxy @Int++strTypeRep :: TypeRep+strTypeRep = typeRep $ Proxy @String++unitTypeRep :: TypeRep+unitTypeRep = typeRep $ Proxy @()

@@ -0,0 +1,214 @@+{-# LANGUAGE CPP #-}++module Servant.API.RoutesSpec+  ( spec+  )+where++import Data.Function+import qualified Data.Set as Set+import qualified Data.Text as T+import GHC.Generics+import Lens.Micro+import Servant.API+import Servant.API.Routes+import Servant.API.Routes.Internal.Response+import Servant.API.Routes.Route+import Servant.API.Routes.RouteSpec ()+import Test.Hspec as H+import Test.Hspec.QuickCheck as H+import Test.QuickCheck as Q++instance Q.Arbitrary Routes where+  -- we use the 'Routes' pattern to handle removing duplicates etc+  arbitrary = Routes <$> Q.arbitrary+  shrink (Routes routes) = Routes <$> Q.shrink routes++type SubAPI = ReqBody '[JSON] String :> Post '[JSON] Int++type SubAPI2 = Header "h1" T.Text :> "x" :> ("y" :> Put '[JSON] String :<|> SubAPI)++type SubAPI3 =+  Header "h1" T.Text+    :> "x"+    :> ( "y" :> Put '[JSON] String+          :<|> "z" :> Header' '[Optional] "h2" Int :> Get '[JSON] [Integer]+       )++intRequest :: Request+intRequest = oneRequest @Int++intResponse :: Responses+intResponse = oneResponse @Int++strResponse :: Responses+strResponse = oneResponse @String++#if MIN_VERSION_servant(0,19,0)+data API mode = API+  { ep1 :: mode :- SubAPI+  , ep2 :: mode :- SubAPI2+  , ep3 :: mode :- SubAPI3+  } deriving Generic+#endif++sameRoutes ::+  forall l r.+  (HasRoutes l, HasRoutes r) =>+  Expectation+sameRoutes = getRoutes @l `shouldMatchList` getRoutes @r++sameRoutesAsSub ::+  forall l.+  (HasRoutes l) =>+  Expectation+sameRoutesAsSub = sameRoutes @l @SubAPI++unchanged ::+  forall l.+  (HasRoutes (l :> SubAPI)) =>+  Expectation+unchanged = sameRoutesAsSub @(l :> SubAPI)++spec :: Spec+spec = do+  describe "Routes" $ do+    describe "makeRoutes/unmakeRoutes" $+      prop "correctly removes duplicates" $+        \routes ->+          let -- ~ routesList = unmakeRoutes routes+              Routes routesList = routes+              -- ~ routes2 = unmakeRoutes (routesList <> routesList)+              routes2 = Routes (routesList <> routesList)+          in  routes2 === routes+  describe "HasRoutes" $ do+    describe "base cases" $ do+      it "EmptyAPI" $ getRoutes @EmptyAPI `shouldMatchList` []+      it "UVerb" $ do+        getRoutes @(UVerb 'POST '[JSON] '[])+          `shouldMatchList` [ defRoute "POST"+                            ]+        getRoutes @(UVerb 'POST '[JSON] '[Int])+          `shouldMatchList` [ defRoute "POST"+                                & routeResponse .~ intResponse+                            ]+        getRoutes @(UVerb 'POST '[JSON] '[Int, String])+          `shouldMatchList` [ defRoute "POST"+                                & routeResponse .~ intResponse <> strResponse+                            ]+        getRoutes @(UVerb 'POST '[JSON] '[Headers '[] Int, String])+          `shouldMatchList` [ defRoute "POST"+                                & routeResponse .~ strResponse <> intResponse+                            ]+        getRoutes+          @( UVerb+              'POST+              '[JSON]+              '[ Headers '[] (Headers '[Header "h2" String] Int)+               , Headers '[Header "h1" [Int], Header "h3" Int] String+               ]+           )+          `shouldMatchList` [ defRoute "POST"+                                & routeResponse+                                  .~ ( strResponse+                                        & unResponses . traversed . responseHeaders+                                          <>~ Set.fromList+                                            [ mkHeaderRep @"h1" @[Int]+                                            , mkHeaderRep @"h3" @Int+                                            ]+                                     )+                                    <> ( intResponse+                                          & (unResponses . traversed . responseHeaders)+                                            `add` (mkHeaderRep @"h2" @String)+                                       )+                            ]+      it "Verb" $ do+        getRoutes @(Post '[JSON] Int) `shouldMatchList` [defRoute "POST" & routeResponse .~ intResponse]+        getRoutes @(Post '[JSON] (Headers '[Header "h1" String] Int))+          `shouldMatchList` [ defRoute "POST"+                                & routeResponse .~ oneResponse @(Headers '[Header "h1" String] Int)+                            ]+      it "Stream" $ do+        getRoutes @(Stream 'POST 201 NoFraming JSON Int) `shouldMatchList` [defRoute "POST" & routeResponse .~ intResponse]++    describe "boring: combinators that don't change routes" $ do+      it "Description" $ unchanged @(Description "desc")+      it "Summary" $ unchanged @(Summary "summary")+      it "Fragment" $ unchanged @(Fragment Int)+      it "Vault" $ unchanged @Vault+      it "HttpVersion" $ unchanged @HttpVersion+      it "IsSecure" $ unchanged @IsSecure+      it "RemoteHost" $ unchanged @RemoteHost+      it "WithNamedContext" $ sameRoutesAsSub @(WithNamedContext "name" '[] SubAPI)++    describe "recursive: some combinators combine or alter routes" $ do+      it ":<|>" $ getRoutes @(SubAPI :<|> SubAPI2) `shouldMatchList` getRoutes @SubAPI <> getRoutes @SubAPI2+      it "NoContentVerb" $+        renderRoute <$> getRoutes @(NoContentVerb 'POST) `shouldMatchList` ["POST /"]+      it "Symbol :>" $ do+        let prep = routePath %~ prependPathPart "sym"+        getRoutes @("sym" :> SubAPI) `shouldMatchList` prep <$> getRoutes @SubAPI+        getRoutes @("sym" :> SubAPI2) `shouldMatchList` prep <$> getRoutes @SubAPI2+        getRoutes @("sym" :> SubAPI3) `shouldMatchList` prep <$> getRoutes @SubAPI3+      it "Header' :>" $ do+        let addH = routeRequestHeaders `add` (mkHeaderRep @"h1" @Int)+        getRoutes @(Header' '[Required] "h1" Int :> SubAPI) `shouldMatchList` addH <$> getRoutes @SubAPI+        getRoutes @(Header' '[Required] "h1" Int :> SubAPI2) `shouldMatchList` addH <$> getRoutes @SubAPI2+        getRoutes @(Header' '[Required] "h1" Int :> SubAPI3) `shouldMatchList` addH <$> getRoutes @SubAPI3+        let addHOptional = routeRequestHeaders `add` (mkHeaderRep @"h1" @(Maybe Int))+        getRoutes @(Header' '[Optional] "h1" Int :> SubAPI) `shouldMatchList` addHOptional <$> getRoutes @SubAPI+        getRoutes @(Header' '[Optional] "h1" Int :> SubAPI2) `shouldMatchList` addHOptional <$> getRoutes @SubAPI2+        getRoutes @(Header' '[Optional] "h1" Int :> SubAPI3) `shouldMatchList` addHOptional <$> getRoutes @SubAPI3+      it "BasicAuth :>" $ do+        let addAuth = routeAuths `add` basicAuth @"realm"+        getRoutes @(BasicAuth "realm" String :> SubAPI) `shouldMatchList` addAuth <$> getRoutes @SubAPI+        getRoutes @(BasicAuth "realm" String :> SubAPI2) `shouldMatchList` addAuth <$> getRoutes @SubAPI2+        getRoutes @(BasicAuth "realm" String :> SubAPI3) `shouldMatchList` addAuth <$> getRoutes @SubAPI3+      it "AuthProtect :>" $ do+        let addAuth = routeAuths `add` customAuth @"my-special-auth"+        getRoutes @(AuthProtect "my-special-auth" :> SubAPI) `shouldMatchList` addAuth <$> getRoutes @SubAPI+        getRoutes @(AuthProtect "my-special-auth" :> SubAPI2) `shouldMatchList` addAuth <$> getRoutes @SubAPI2+        getRoutes @(AuthProtect "my-special-auth" :> SubAPI3) `shouldMatchList` addAuth <$> getRoutes @SubAPI3+      it "QueryFlag :>" $ do+        let addFlag = routeParams `add` (flagParam @"sym")+        getRoutes @(QueryFlag "sym" :> SubAPI) `shouldMatchList` addFlag <$> getRoutes @SubAPI+        getRoutes @(QueryFlag "sym" :> SubAPI2) `shouldMatchList` addFlag <$> getRoutes @SubAPI2+        getRoutes @(QueryFlag "sym" :> SubAPI3) `shouldMatchList` addFlag <$> getRoutes @SubAPI3+      it "QueryParam' :>" $ do+        let addP = routeParams `add` (singleParam @"h1" @Int)+        getRoutes @(QueryParam' '[Required] "h1" Int :> SubAPI) `shouldMatchList` addP <$> getRoutes @SubAPI+        getRoutes @(QueryParam' '[Required] "h1" Int :> SubAPI2) `shouldMatchList` addP <$> getRoutes @SubAPI2+        getRoutes @(QueryParam' '[Required] "h1" Int :> SubAPI3) `shouldMatchList` addP <$> getRoutes @SubAPI3+        let addPOptional = routeParams `add` (singleParam @"h1" @(Maybe Int))+        getRoutes @(QueryParam' '[Optional] "h1" Int :> SubAPI) `shouldMatchList` addPOptional <$> getRoutes @SubAPI+        getRoutes @(QueryParam' '[Optional] "h1" Int :> SubAPI2) `shouldMatchList` addPOptional <$> getRoutes @SubAPI2+        getRoutes @(QueryParam' '[Optional] "h1" Int :> SubAPI3) `shouldMatchList` addPOptional <$> getRoutes @SubAPI3+      it "QueryParams :>" $ do+        let addP = routeParams `add` (arrayElemParam @"h1" @Int)+        getRoutes @(QueryParams "h1" Int :> SubAPI) `shouldMatchList` addP <$> getRoutes @SubAPI+        getRoutes @(QueryParams "h1" Int :> SubAPI2) `shouldMatchList` addP <$> getRoutes @SubAPI2+        getRoutes @(QueryParams "h1" Int :> SubAPI3) `shouldMatchList` addP <$> getRoutes @SubAPI3+      it "ReqBody' :>" $ do+        let addB = routeRequestBody <>~ intRequest+        getRoutes @(ReqBody '[JSON] Int :> SubAPI) `shouldMatchList` addB <$> getRoutes @SubAPI+        getRoutes @(ReqBody '[JSON] Int :> SubAPI2) `shouldMatchList` addB <$> getRoutes @SubAPI2+        getRoutes @(ReqBody '[JSON] Int :> SubAPI3) `shouldMatchList` addB <$> getRoutes @SubAPI3+      it "StreamBody' :>" $ do+        let addB = routeRequestBody <>~ intRequest+        getRoutes @(ReqBody '[JSON] Int :> SubAPI) `shouldMatchList` addB <$> getRoutes @SubAPI+        getRoutes @(ReqBody '[JSON] Int :> SubAPI2) `shouldMatchList` addB <$> getRoutes @SubAPI2+        getRoutes @(StreamBody NoFraming JSON Int :> SubAPI3) `shouldMatchList` addB <$> getRoutes @SubAPI3+      it "Capture' :>" $ do+        let addC = routePath %~ prependCapturePart @Int "cap"+        getRoutes @(Capture "cap" Int :> SubAPI) `shouldMatchList` addC <$> getRoutes @SubAPI+        getRoutes @(Capture "cap" Int :> SubAPI2) `shouldMatchList` addC <$> getRoutes @SubAPI2+        getRoutes @(Capture "cap" Int :> SubAPI3) `shouldMatchList` addC <$> getRoutes @SubAPI3+      it "CaptureAll :>" $ do+        let addC = routePath %~ prependCaptureAllPart @Int "cap"+        getRoutes @(CaptureAll "cap" Int :> SubAPI) `shouldMatchList` addC <$> getRoutes @SubAPI+        getRoutes @(CaptureAll "cap" Int :> SubAPI2) `shouldMatchList` addC <$> getRoutes @SubAPI2+        getRoutes @(CaptureAll "cap" Int :> SubAPI3) `shouldMatchList` addC <$> getRoutes @SubAPI3+#if MIN_VERSION_servant(0,19,0)+      it "NamedRoutes" $+        getRoutes @(NamedRoutes API) `shouldMatchList` getRoutes @SubAPI <> getRoutes @SubAPI2 <> getRoutes @SubAPI3+#endif

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}