servant-benchmark (empty) → 0.1.0.0

raw patch · 16 files changed

+1166/−0 lines, 16 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, base64-bytestring, bytestring, case-insensitive, hspec, http-media, http-types, servant, servant-benchmark, text, yaml

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +102/−0
• Setup.hs +2/−0
• servant-benchmark.cabal +83/−0
• src/Servant/Benchmark.hs +21/−0
• src/Servant/Benchmark/BasicAuth.hs +19/−0
• src/Servant/Benchmark/Endpoint.hs +104/−0
• src/Servant/Benchmark/Generator.hs +156/−0
• src/Servant/Benchmark/HasEndpoint.hs +282/−0
• src/Servant/Benchmark/HasGenerator.hs +36/−0
• src/Servant/Benchmark/ToText.hs +57/−0
• src/Servant/Benchmark/Tools/Drill.hs +78/−0
• src/Servant/Benchmark/Tools/Siege.hs +39/−0
• src/Servant/Benchmark/Tools/Wrk.hs +56/−0
• test/Spec.hs +98/−0

@@ -0,0 +1,3 @@+# Changelog for servant-wrt++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Kyriakos Papachrysanthou (c) 2021++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 Author name here 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,102 @@+# servant-benchmark++A library for producing random request data from *Servant* APIs. ++## Building a `Generator`++The `Generator` type must closely follow the structure of the *Servant* API. ++* Different endpoints are combined with the `:|:` operator+* Different generators are combined with the `:>:` operator+* Every endpoint must end with a  `(Text, Word)` tuple consisting of the endpoint name and its corresponding weight.+  Endpoint names are only used for additional information passed to the benchmark implementations+  and do not have to follow specific rules. That being said, generators for extensive APIs can get+  rather big and hard to read, so providing sensible naming could be very beneficial.  +* The weight of an endpoint specifies the number of instances per testing run+  of the API. Endpoints with 0 weight will be ignored.+* For every API combinator expecting a request value, a `Gen a` random value generator from the+  [QuickCheck](https://hackage.haskell.org/package/QuickCheck) package must be provided. +  The following combinators require a value generator:+    * `ReqBody`+    * `QueryParams`+    * `Capture`+    * `CaptureAll`+    * `Header`+    * `Fragment`+* For the `BasicAuth` combinator, see the dedicated section below ++As an example, the following is a valid `Generator` for a contrived servant API++````haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++type API = +    "books" :> Get '[JSON] [Book]+    :<|> "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer+    :<|> "users" :> Capture "userId" Integer :> ReqBody '[JSON] User :> Put '[JSON] User+    :<|> "post" :> QueryParam "segments" Text :> Get '[JSON] Post+    :<|> Raw++generator :: Generator API+let generator =+    ("books", 1)+    :|: arbitrary :>: ("referer", 2)+    :|: pure 1001 :>: arbitrary :>: ("users endpoint", 2)+    :|: elements ["title", "contents", "post"] :>: ("post", 4)+    :|: ("raw", 0)+````++The first endpoint "books" does not require request data and so only the name / weight tuple is+provided.++The "view-my-referer" endpoint requires a "from" header with an accompanying `Referer` value. Here+we assume `Referer` has an `Arbitrary` instance to provide a random value. The endpoint generator+finishes with the name/weight indication.++The "users" endpoint requires two different request values. An Integer capture representing a user+id as well as a `User` value. We hard-code the user id to `1001` using the monadic `pure` and assume that+`User` has an `Arbitrary` instance to produce a random value. We finish with the endpoint's name/weight as necessary.++The "post" endpoint requires a `Text` query parameter. We provide a fixed set of possible values+using the `elements` function from the `QuickCheck` package. With a weight of 4, four instances of+the "post" endpoint will be produced, each with a random value from the specified set.++Finally our API provides a `Raw` endpoint for serving static files, but we'd rather not benchmark+it. Providing a 0 weight ensures that no request will be generated ++### Basic Auth++A generator for an endpoint using a `BasicAuth` combinator requires both a function to convert the+requested user data type to `BasicAuthData` as well as a `Gen` value for the requested user data. ++example:++````haskell+type privateAPI = "private" :> BasicAuth "foo-realm" User :> PrivateAPI++toBasicAuthData :: User -> BasicAuthData+toBasicAuthData user = ... ++-- assuming `User` has an `Arbitrary` instance+let generator = toBasicAuthData :>: arbitrary :>: ("basicAuth", 1)+````++The information will be encoded as an `Authorization` header.++## Supported tools++The following benchmarking tools are supported :++- [wrk](https://github.com/wg/wrk)+- [Drill](https://github.com/fcsonline/drill)+- [Siege](src/Servant/Benchmark/Tools/Siege.hs)++If you'd like your favorite tool to be supported, don't hesitate to tell me so in an issue,+or better yet submit a PR.++## Next steps++* Provide support for *servant-auth* combinators+* Expand the support for benchmarking frameworks

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,83 @@+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: 9f56c147463a61695fc2d6676052796cde29111cfa25450c97615c152f33c585++name:           servant-benchmark+version:        0.1.0.0+synopsis:       Generate benchamrk files from a Servant API+description:    Please see the README on GitHub at <https://github.com/3kyro/servant-benchmark#README>+category:       Web+homepage:       https://github.com/3kyro/servant-benchmark#readme+bug-reports:    https://github.com/3kyro/servant-benchmark/issues+author:         Kyriakos Papachrysanthou+maintainer:     papachrysanthou.k@gmaim.com+copyright:      2021 Kyriakos Papachrysanthou+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/3kyro/servant-benchmark++library+  exposed-modules:+      Servant.Benchmark+      Servant.Benchmark.BasicAuth+      Servant.Benchmark.Endpoint+      Servant.Benchmark.Generator+      Servant.Benchmark.HasEndpoint+      Servant.Benchmark.HasGenerator+      Servant.Benchmark.Tools.Drill+      Servant.Benchmark.Tools.Siege+      Servant.Benchmark.Tools.Wrk+      Servant.Benchmark.ToText+  other-modules:+      Paths_servant_benchmark+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , base64-bytestring+    , bytestring+    , case-insensitive+    , http-media+    , http-types+    , servant+    , text+    , yaml+  default-language: Haskell2010++test-suite servant-benchmark-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_servant_benchmark+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -fprint-potential-instances+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , base64-bytestring+    , bytestring+    , case-insensitive+    , hspec+    , http-media+    , http-types+    , servant+    , servant-benchmark+    , text+    , yaml+  default-language: Haskell2010

@@ -0,0 +1,21 @@+{-# LANGUAGE ExplicitNamespaces #-}++{- | A library for producing random request data from Servant APIs.++Visit the project's [repository](https://github.com/3kyro/servant-benchmark) for more information.+-}+module Servant.Benchmark (+    Generator,++    -- * Generator builders+    (:|:) (..),+    (:>:) (..),+    HasGenerator (..),+    HasEndpoint (..),+    Endpoint (..),+) where++import Servant.Benchmark.Endpoint+import Servant.Benchmark.Generator+import Servant.Benchmark.HasEndpoint (HasEndpoint (..))+import Servant.Benchmark.HasGenerator

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module Servant.Benchmark.BasicAuth where++import Data.ByteString.Base64 (encode)+import Data.ByteString.Char8 as BS8+import Network.HTTP.Types (Header, hAuthorization)+import Servant.API (BasicAuthData (..))+import Test.QuickCheck (Gen)+import Test.QuickCheck.Gen (generate)++{- | Given a function (a -> BasicAuthData), produce an authorization header from a+ random value of `a`+-}+encodeBasicAuth :: (a -> BasicAuthData) -> Gen a -> IO Header+encodeBasicAuth f gen = do+    basicAuthData <- f <$> generate gen+    let bs64 = BS8.pack "Basic " <> encode (basicAuthUsername basicAuthData <> BS8.singleton ':' <> basicAuthPassword basicAuthData)+    pure (hAuthorization, bs64)

@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++module Servant.Benchmark.Endpoint where++import Control.Applicative ((<|>))+import qualified Data.ByteString as BS+import Data.CaseInsensitive (mk)+import Data.Maybe (maybeToList)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Media (MediaType, RenderHeader (renderHeader), (//), (/:))+import Network.HTTP.Types (Method, hContentType)+import Network.HTTP.Types.Header (Header)++{- | An API endpoint.+-+-}+data Endpoint = MkEndpoint+    { name :: T.Text+    , -- All endpoint request paths+      path :: T.Text+    , -- The endpoint request method+      method :: Maybe Method+    , -- | The request value, where applicable.+      -- Only the first encountered request value is taken into consideration+      -- eg. "user" :> ReqBody '[JSON] Text :> ReqBody '[JSON] Int :> Get '[JSON] User+      -- will produce only a `Text` based request value+      body :: Maybe BS.ByteString+    , -- | The requests content type.+      -- Only the first encountered content type is taken into consideration.+      -- If you're building an endpoint manually, you should enter the media type here+      -- rather than directly in headers. All implementations automatically include the+      -- content type header during benchmark configuration output.+      contentType :: Maybe MediaType+    , -- | The request headers+      headers :: [Header]+    }+    deriving (Show, Eq)++instance Semigroup Endpoint where+    a <> b =+        MkEndpoint+            (name a <> name b)+            (path a <> path b)+            (method a <> method b)+            (body a <|> body b)+            (contentType a <|> contentType b)+            (headers a <> headers b)++instance Monoid Endpoint where+    mempty = MkEndpoint mempty mempty mempty Nothing Nothing []++{- | Pack an endpoint created from an API interpretation in a form+ ready to be serialized.+ - This is only useful if your are building your own output.+-}+pack :: Endpoint -> Endpoint+pack endpoint =+    endpoint+        { contentType = Nothing+        , headers = ct ++ headers endpoint+        }+  where+    ct = maybeToList ctHeader+    ctHeader = (,) hContentType <$> fmap renderHeader (contentType endpoint)++-- | Create a `Header` from two `Text` inputs+mkHeader :: T.Text -> T.Text -> Header+mkHeader ciName value =+    (mk $ T.encodeUtf8 ciName, T.encodeUtf8 value)++-- * Content Types++-- | application/json+ctJSON :: MediaType+ctJSON = hApplication // hJSON++-- | text/plain ; charset=utf-8+ctPlainText :: MediaType+ctPlainText = hText // hPlain /: (hCharset, hUTF8)++-- | application+hApplication :: BS.ByteString+hApplication = "application"++-- | json+hJSON :: BS.ByteString+hJSON = "json"++-- | text+hText :: BS.ByteString+hText = "text"++-- | plain+hPlain :: BS.ByteString+hPlain = "plain"++-- | charset+hCharset :: BS.ByteString+hCharset = "charset"++-- | utf-8+hUTF8 :: BS.ByteString+hUTF8 = "utf-8"

@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |++A Generator provides value level interpretation of an API.+-}+module Servant.Benchmark.Generator where++import Data.Kind (Type)+import qualified Data.Text as T+import GHC.Base (Nat, Symbol)+import Servant.API+import Test.QuickCheck (Gen)++{- | Value level `Generator` combinator. Combine endpoint generators to build an API generator++example:++@+-- The API we want to benchmark+type API = "books" :> Get '[JSON] Book :<|> "authors" :> "authors" :> ReqBody '[PlainText] String :> Post '[JSON] [Author]++generator :: Generator API+generator = ("books", 1) :|: elements ["Cervantes", "Kant"] :>: ("authors", 2)+@+-}+data (a :: Type) :|: (b :: Type) = a :|: b++infixr 3 :|:++{- | Value level `Generator` combinator. Build endpoint generators by combining `Gen` values with (description, weight) tuples++ example:++ @+ -- A single endpoint API+ type API = "authors" :> "authors" :> ReqBody '[PlainText] String :> Post '[JSON] [Author]++generator :: Generator API+generator = elements ["Cervantes", "Kant"] :>: ("authors", 2)+@+-}+data (a :: Type) :>: (b :: Type) = a :>: b++infixr 9 :>:++{- |++A Generator provides value level interpretation of an API.++The `Generator` type must closely follow the structure of the `Servant` API.++* Different endpoints are combined with the `:|:` operator+* Different generators are combined with the `:>:` operator+* Every endpoint must end with a  `(Text, Word)` tuple consisting of the endpoint name and its corresponding weight.+  Endpoint names are only used for additional information passed to the benchmark implementations+  and do not have to follow specific rules. That being said, generators for extensive APIs can get+  rather big and hard to read, so providing sensible naming could be very beneficial.+* The weight of an endpoint specifies the number of instances per testing run+  of the API. Endpoints with 0 weight will be ignored.+* For every API combinator expecting a request value, a `Gen a` random value generator from the+  [QuickCheck](https://hackage.haskell.org/package/QuickCheck) package must be provided.+* The following combinators require a value generator:++    * `ReqBody`+    * `QueryParams`+    * `Capture`+    * `CaptureAll`+    * `Header`+    * `Fragment`++* For the `BasicAuth` combinator, see the dedicated section below++As an example, the following is a valid `Generator` for a contrived servant API++@+type API =+    "books" :> Get '[JSON] [Book]+    :<|> "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer+    :<|> "users" :> Capture "userId" Integer :> ReqBody '[JSON] User :> Put '[JSON] User+    :<|> "post" :> QueryParam "segments" Text :> Get '[JSON] Post+    :<|> Raw++generator :: Generator API+let generator =+    ("books", 1)+    :|: arbitrary :>: ("referer", 2)+    :|: pure 1001 :>: arbitrary :>: ("users endpoint", 2)+    :|: elements ["title", "contents", "post"] :>: ("post", 4)+    :|: ("raw", 0)+@++The first endpoint "books" does not require request data and so only the name / weight tuple is+provided.++The "view-my-referer" endpoint requires a "from" header with an accompanying `Referer` value. Here+we assume `Referer` has an `Arbitrary` instance to provide a random value. The endpoint generator+finishes with the name/weight indication.++The "users" endpoint requires two different request values. An Integer capture representing a user+id as well as a `User` value. We hard-code the user id to `1001` using the monadic `pure` and assume that+`User` has an `Arbitrary` instance to produce a random value. We finish with the endpoint's name/weight as necessary.++The "post" endpoint requires a `Text` query parameter. We provide a fixed set of possible values+using the `elements` function from the `QuickCheck` package. With a weight of 4, four instances of+the "post" endpoint will be produced, each with a random value from the specified set.++Finally our API provides a `Raw` endpoint for serving static files, but we'd rather not benchmark+it. Providing a 0 weight ensures that no request will be generated++== Basic Auth++A generator for an endpoint using a `BasicAuth` combinator requires both a function to convert the+requested user data type to `BasicAuthData` as well as a `Gen` value for the requested user data.++example:++@+type privateAPI = "private" :> BasicAuth "foo-realm" User :> PrivateAPI++toBasicAuthData :: User -> BasicAuthData+toBasicAuthData user = ...++-- assuming `User` has an `Arbitrary` instance+let generator = toBasicAuthData :>: arbitrary :>: ("basicAuth", 1)+@++The information will be encoded as an `Authorization` header.+-}+type family Generator (api :: Type) where+    Generator (a :<|> b) = Generator a :|: Generator b+    Generator (Verb (method :: k) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type)) = (T.Text, Word)+    Generator (ReqBody '[JSON] (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator (ReqBody '[PlainText] (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator (QueryParams params a :> rest) = Gen a :>: Generator rest+    Generator ((sym :: Symbol) :> rest) = Generator rest+    Generator (HttpVersion :> rest) = Generator rest+    Generator (QueryFlag (sym :: Symbol) :> rest) = Generator rest+    Generator (Capture (sym :: Symbol) String :> rest) = Gen String :>: Generator rest+    Generator (Capture (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator (CaptureAll (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator (Header (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator (Fragment (a :: Type) :> rest) = Gen a :>: Generator rest+    Generator EmptyAPI = (T.Text, Word)+    Generator (RemoteHost :> rest) = Generator rest+    Generator (IsSecure :> rest) = Generator rest+    Generator (WithNamedContext (name :: Symbol) (sub :: [Type]) (api :: Type)) = Generator api+    Generator (BasicAuth (realm :: Symbol) (userData :: Type) :> rest) =+        (userData -> BasicAuthData) :>: Gen userData :>: Generator rest+    Generator (Description (sym :: Symbol) :> rest) = Generator rest+    Generator (Summary (sym :: Symbol) :> rest) = Generator rest+    Generator Raw = (T.Text, Word)

@@ -0,0 +1,282 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Benchmark.HasEndpoint (HasEndpoint (..)) where++import Data.Aeson (ToJSON)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Data (Proxy (..))+import Data.Kind (Type)+import Data.List (foldl')+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.TypeLits (KnownSymbol, Nat, Symbol, symbolVal)+import Servant.API hiding (contentType, contentTypes)+import Servant.Benchmark.BasicAuth (encodeBasicAuth)+import Servant.Benchmark.Endpoint (Endpoint (..), ctJSON, ctPlainText, mkHeader)+import Servant.Benchmark.Generator (Generator, (:>:) (..))+import Servant.Benchmark.ToText+import Test.QuickCheck (generate, listOf)++-- | HasEndpoint provides type level interpretation of an API Endpoint+class HasEndpoint (api :: Type) where+    getEndpoint :: Proxy api -> Generator api -> IO Endpoint+    weight :: Proxy api -> Generator api -> Word++-- Instance for ' "path" :> .... " parts+-- Add sym to the path and continue+instance+    forall (sym :: Symbol) (rest :: Type).+    (KnownSymbol sym, HasEndpoint rest) =>+    HasEndpoint (sym :> rest)+    where+    getEndpoint _ gen = do+        (<>) mempty{path = T.pack $ '/' : symbolVal (Proxy @sym)}+            <$> getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for common verbs - e.g. GET, PUT etc+-- A verb is always the last part of the API and so does not continue the interpretation. As such the+-- endpoint's description and weight are parsed here.+instance+    forall k (method :: k) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type).+    ReflectMethod method =>+    HasEndpoint (Verb method statusCode contentTypes a)+    where+    getEndpoint _ gen =+        pure $+            mempty+                { name = fst gen+                , method = Just $ reflectMethod (Proxy @method)+                }+    weight _ gen = snd gen++-- Instance for Request body combinators.+-- A separate instance for each content type is provided.+-- Instances exist for JSON and PLAINTEXT content types.+-- A Generator for body type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (a :: Type) (rest :: Type).+    (ToJSON a, HasEndpoint rest) =>+    HasEndpoint (ReqBody '[JSON] a :> rest)+    where+    getEndpoint _ (genLeft :>: genRest) = do+        value <- generate genLeft+        (<>)+            mempty+                { body = Just $ BS.toStrict $ A.encode value+                , contentType = Just ctJSON+                }+            <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++instance+    forall (a :: Type) (rest :: Type).+    (ToText a, HasEndpoint rest) =>+    HasEndpoint (ReqBody '[PlainText] a :> rest)+    where+    getEndpoint _ (genLeft :>: genRest) = do+        value <- generate genLeft+        (<>)+            mempty+                { body = Just $ T.encodeUtf8 $ toText value+                , contentType = Just ctPlainText+                }+            <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for query parameters.+-- Query parameters of the form `QueryParams "root" Word` should produce a path segment similar to:+-- `?root[]=<1>&root[]=<2>`+-- A Generator for the query type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (params :: Symbol) (a :: Type) (rest :: Type).+    (KnownSymbol params, ToText a, HasEndpoint rest) =>+    HasEndpoint (QueryParams params a :> rest)+    where+    getEndpoint _ (genLeft :>: genRest) = do+        let queryPath = T.pack $ symbolVal (Proxy @params)+        arbParams <- generate $ listOf genLeft+        -- build the query parameters, throwing away the trailing '&'+        let queryParams = T.init $ foldl' (addParam queryPath) "" arbParams+        -- concat the endpoint with the rest+        (<>) mempty{path = '?' `T.cons` queryParams}+            <$> getEndpoint (Proxy @rest) genRest+      where+        addParam :: T.Text -> T.Text -> a -> T.Text+        addParam root acc a =+            acc <> root <> "[]=<" <> toText a <> ">&"+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for query flags+-- Query flags of the form `QueryFlag "flag"` should produce a path segment similar to `?flag`+instance+    forall (sym :: Symbol) (rest :: Type).+    (KnownSymbol sym, HasEndpoint rest) =>+    HasEndpoint (QueryFlag sym :> rest)+    where+    getEndpoint _ gen =+        (<>) mempty{path = T.pack $ "?" ++ symbolVal (Proxy @sym)}+            <$> getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for Capture combinator+-- A capture of the form `Capture "root" Int" should produce a path segment `/12`+-- A Generator for the capture type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (sym :: Symbol) (a :: Type) (rest :: Type).+    (ToText a, HasEndpoint rest) =>+    HasEndpoint (Capture sym a :> rest)+    where+    getEndpoint _ (gen :>: genRest) = do+        value <- generate gen+        -- concat the endpoint with the rest+        (<>) mempty{path = '/' `T.cons` toText value} <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for CaptureAll combinator+-- A capture of the form `CaptureAll "root" Int" should produce a path segment `/12`+-- A Generator for the capture type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (sym :: Symbol) (a :: Type) (rest :: Type).+    (ToText a, HasEndpoint rest) =>+    HasEndpoint (CaptureAll sym a :> rest)+    where+    getEndpoint _ (gen :>: genRest) = do+        value <- generate gen+        -- concat the endpoint with the rest+        (<>) mempty{path = '/' `T.cons` toText value} <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for Header combinator+-- A Generator for the header type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (sym :: Symbol) (a :: Type) (rest :: Type).+    (KnownSymbol sym, ToText a, HasEndpoint rest) =>+    HasEndpoint (Header sym a :> rest)+    where+    getEndpoint _ (gen :>: genRest) = do+        let headerName = T.pack $ symbolVal (Proxy @sym)+        headerValue <- generate gen+        let header = mkHeader headerName $ toText headerValue+        -- concat the endpoint with the rest+        (<>) mempty{headers = [header]} <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for HttpVersion combinator+-- No intermediate endpoint is produced+instance+    forall (rest :: Type).+    HasEndpoint rest =>+    HasEndpoint (HttpVersion :> rest)+    where+    getEndpoint _ gen = getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for the EmptyAPI combinator.+-- EmptyAPI is considered the unit value for top level API combinators.+-- As such, including EmptyAPI will finish the interpretation with an empty endpoint and zero weight.+instance HasEndpoint EmptyAPI where+    getEndpoint _ gen = pure mempty{name = fst gen}+    weight _ _ = 0++-- Instance for the fragment combinator.+-- A Generator for the fragment type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (a :: Type) (rest :: Type).+    (ToText a, HasEndpoint rest) =>+    HasEndpoint (Fragment a :> rest)+    where+    getEndpoint _ (gen :>: genRest) = do+        value <- generate gen+        (<>) mempty{path = '#' `T.cons` toText value}+            <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for RemoteHost combinator+-- No intermediate endpoint is produced+instance+    forall (rest :: Type).+    HasEndpoint rest =>+    HasEndpoint (RemoteHost :> rest)+    where+    getEndpoint _ gen = getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for IsSecure combinator+-- No intermediate endpoint is produced+instance+    forall (rest :: Type).+    HasEndpoint rest =>+    HasEndpoint (IsSecure :> rest)+    where+    getEndpoint _ gen = getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for the WithNamedContext combinator.+-- No intermediate endpoint is produced+instance+    forall (name :: Symbol) (sub :: [Type]) (api :: Type).+    HasEndpoint api =>+    HasEndpoint (WithNamedContext name sub api)+    where+    getEndpoint _ gen = getEndpoint (Proxy @api) gen+    weight _ gen = weight (Proxy @api) gen++-- Instance for the BasicAuth combinator.+-- An authorization header is added to the endpoint.+-- A Generator for the userData type is expected. This generator is extracted and+-- the remaining part is passed on.+instance+    forall (realm :: Symbol) (userData :: Type) (rest :: Type).+    (HasEndpoint rest) =>+    HasEndpoint (BasicAuth realm userData :> rest)+    where+    getEndpoint _ (f :>: genUserData :>: genRest) = do+        authHeader <- encodeBasicAuth f genUserData+        -- concat the endpoint with the rest+        (<>)+            mempty{headers = [authHeader]}+            <$> getEndpoint (Proxy @rest) genRest+    weight _ (_ :>: _ :>: genRest) = weight (Proxy @rest) genRest++-- Instance for the Description combinator.+-- No intermediate endpoint is produced+instance+    forall (sym :: Symbol) (rest :: Type).+    HasEndpoint rest =>+    HasEndpoint (Description sym :> rest)+    where+    getEndpoint _ gen = getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for the Summary combinator.+-- No intermediate endpoint is produced+instance+    forall (sym :: Symbol) (rest :: Type).+    HasEndpoint rest =>+    HasEndpoint (Summary sym :> rest)+    where+    getEndpoint _ gen = getEndpoint (Proxy @rest) gen+    weight _ gen = weight (Proxy @rest) gen++-- Instance for the Raw combinator.+-- Raw is a final combinator and so endpoint name and weight are+-- extracted.+instance HasEndpoint Raw where+    getEndpoint _ gen = pure mempty{name = fst gen}+    weight _ gen = snd gen

@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.Benchmark.HasGenerator where++import Control.Monad (replicateM)+import Data.Data (Proxy (..))+import Data.Kind (Type)+import Servant.API+import Servant.Benchmark.Endpoint (Endpoint)+import Servant.Benchmark.Generator+import Servant.Benchmark.HasEndpoint++{- | HasGenerator provides combined type and value level interpretation of an API,+  producing corresponding `Endpoint` values.++  Instructions on forming a `Generator` type can be found on the module documentation.+-}+class HasGenerator api where+    generate :: Proxy api -> Generator api -> IO [Endpoint]++instance {-# OVERLAPPABLE #-} (HasEndpoint a, HasGenerator b) => HasGenerator (a :<|> b) where+    generate :: Proxy (a :<|> b) -> Generator (a :<|> b) -> IO [Endpoint]+    generate _ (hLeft :|: hRight) = do+        left <- generate (Proxy @a) hLeft+        right <- generate (Proxy @b) hRight+        pure $ left ++ right++instance {-# OVERLAPPABLE #-} forall (a :: Type). HasEndpoint a => HasGenerator a where+    generate p gen =+        replicateM (fromIntegral $ weight p gen) (getEndpoint p gen)

@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.Benchmark.ToText (ToText (..)) where++import qualified Data.ByteString as BS+import Data.Data (Proxy (Proxy))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types (Method)++-- | Types that can be converted to Text and serialized.+class ToText a where+    toText :: a -> T.Text++instance (HasText a ~ textType, HasTextRepresentation textType a) => ToText a where+    toText = typeToText (Proxy @textType)++-- Types that have a Text representation as defined by the HasText type family.+-- The class helps to avoid using `show` on types that can be easily converted to `Text`+class HasTextRepresentation (s :: TextType) a where+    typeToText :: Proxy s -> a -> T.Text++instance HasTextRepresentation 'TypeString String where+    typeToText _ = T.pack++instance HasTextRepresentation 'TypeText T.Text where+    typeToText _ = id++instance HasTextRepresentation 'TypeByteString BS.ByteString where+    typeToText _ = T.decodeUtf8++instance HasTextRepresentation 'TypeMethod Method where+    typeToText _ = T.decodeUtf8++instance Show a => HasTextRepresentation 'TypeShow a where+    typeToText _ = T.pack . show++data TextType+    = TypeString+    | TypeText+    | TypeByteString+    | TypeMethod+    | TypeShow++type family HasText a where+    HasText String = 'TypeString+    HasText T.Text = 'TypeText+    HasText BS.ByteString = 'TypeByteString+    HasText a = 'TypeShow

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++{- |+Support for the [Drill](https://github.com/fcsonline/drill) load testing application+-}+module Servant.Benchmark.Tools.Drill (Settings (..), export) where++import Data.Aeson (ToJSON (..), object, (.=))+import Data.Aeson.Types (Pair, Value)+import qualified Data.ByteString as BS+import Data.CaseInsensitive (original)+import Data.Ord (comparing)+import qualified Data.Text as T+import qualified Data.Yaml.Pretty as Y+import Network.HTTP.Types (Header)+import Servant.Benchmark.Endpoint+import Servant.Benchmark.ToText++-- | Drill specific settings. See the project's [ documentation ](https://github.com/fcsonline/drill) for more details+data Settings = MkSettings+    { concurrency :: Word+    , base :: T.Text+    , iterations :: Word+    , rampup :: Word+    }++data Output = MkOutput Settings [Endpoint]++instance ToJSON Output where+    toJSON (MkOutput settings plan) =+        object+            [ "concurrency" .= concurrency settings+            , "base" .= base settings+            , "iterations" .= iterations settings+            , "rampup" .= rampup settings+            , "plan"+                .= requests plan+            ]++requests :: [Endpoint] -> [Value]+requests endpoints = endpointToJSON <$> endpoints++endpointToJSON :: Endpoint -> Value+endpointToJSON endpoint =+    object+        [ "name" .= name endpoint+        , "request"+            .= object+                [ "url" .= path endpoint+                , "method" .= fmap toText (method endpoint)+                , "body" .= fmap toText (body endpoint)+                , "headers"+                    .= object+                        (headerToValue <$> headers endpoint)+                ]+        ]++headerToValue :: Header -> Pair+headerToValue (headerName, value) =+    toText (original headerName) .= toText value++-- | Export a benchmark file given a list of `Endpoint`s+export :: FilePath -> Settings -> [Endpoint] -> IO ()+export filepath settings endpoints = do+    let output = MkOutput settings $ pack <$> endpoints+    let encoding = Y.encodePretty config output+    BS.writeFile filepath encoding++config :: Y.Config+config =+    Y.setConfCompare ordering Y.defConfig++-- Explicit ordering for root Yaml fields+ordering :: T.Text -> T.Text -> Ordering+ordering "plan" _ = GT+ordering _ "plan" = LT+ordering t1 t2 = comparing T.length t1 t2

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++Support for the [Siege](https://www.joedog.org/siege-home/) http load testing and benchmarking utility.+-}+module Servant.Benchmark.Tools.Siege (export, Settings (..)) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types (parseMethod)+import Servant.API.Verbs+import Servant.Benchmark.Endpoint++-- | Siege settings.+newtype Settings = MkSettings+    {root :: T.Text}++serialize :: Settings -> Endpoint -> BS.ByteString+serialize (MkSettings rootPath) endpoint =+    case method endpoint of+        Nothing -> T.encodeUtf8 $ rootPath <> path endpoint+        Just actualMethod ->+            case parseMethod actualMethod of+                Right GET -> T.encodeUtf8 $ rootPath <> path endpoint+                Right POST -> T.encodeUtf8 (rootPath <> path endpoint <> " POST ") <> fromMaybe "" (body endpoint)+                _ -> BS.empty++{- | Export a URL files path.+  Note that since Siege-@.06 and later, only the POST and GET directives are supported.+  All other methods will not produce a url in the URLs file.+-}+export :: FilePath -> Settings -> [Endpoint] -> IO ()+export file settings endpoints = do+    let serialized = BS8.unlines $ filter (not . BS8.null) $ map (serialize settings . pack) endpoints+    BS.writeFile file serialized

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- |+This module provides support for the [wrk](https://github.com/wg/wrk) benchmarking tool.++Given a Servant API and a list of `Endpoint`s, the `export` function can produce a requests file containing+a JSON representation of the provided `Endpoint`s.++In order to provide wrk the request data, you can use a simple lua script as described in [this](http://czerasz.com/2015/07/19/wrk-http-benchmarking-tool-example/) tutorial.++An adapted version of the original script by Michael Czeraszkiewicz can be found in the project's [ repository ](https://github.com/3kyro/servant-benchmark/tree/main/scripts)+-}+module Servant.Benchmark.Tools.Wrk (export) where++import Data.Aeson+import Data.Aeson.Types (Pair)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.CaseInsensitive (original)+import Network.HTTP.Types (Header)+import Servant.Benchmark (Endpoint (..))+import Servant.Benchmark.Endpoint (pack)+import Servant.Benchmark.ToText++newtype Output = MkOutput Endpoint++instance ToJSON Output where+    toJSON (MkOutput endpoint) =+        object+            [ "path" .= path endpoint+            , "body" .= fmap toText (body endpoint)+            , "method" .= fmap toText (method endpoint)+            , "headers"+                .= object+                    (headerToValue <$> headers endpoint)+            ]++    toEncoding (MkOutput endpoint) =+        pairs $+            "path" .= path endpoint+                <> "body" .= fmap toText (body endpoint)+                <> "method" .= fmap toText (method endpoint)+                <> "headers"+                    .= object+                        (headerToValue <$> headers endpoint)++headerToValue :: Header -> Pair+headerToValue (headerName, value) =+    toText (original headerName) .= toText value++-- | Export a requests file given a list of `Endpoint`s+export :: FilePath -> [Endpoint] -> IO ()+export filepath endpoints = do+    let encoding = encode $ MkOutput . pack <$> endpoints+    BS.writeFile filepath $ BSL.toStrict encoding

@@ -0,0 +1,98 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import Data.ByteString.Base64 (decode, encode)+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.UTF8 (fromString)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types (hAuthorization, methodDelete, methodGet, methodPost, methodPut)+import Servant+import Servant.Benchmark+import qualified Servant.Benchmark.Tools.Drill as D+import qualified Servant.Benchmark.Tools.Siege as Siege+import qualified Servant.Benchmark.Tools.Wrk as Wrk+import Test.Hspec+import Test.QuickCheck (arbitrary)++main :: IO ()+main = do+    generateSpec+    basicAuthSpec++generators =+    ("get", 3)+        :|: arbitrary :>: ("zero", 0)+        :|: arbitrary :>: ("first", 1)+        :|: arbitrary :>: ("third", 1)+        :|: arbitrary :>: ("context", 1)+        :|: ("capture", 1)+        :|: pure "first value" :>: pure "second value" :>: ("headers", 1)+        :|: pure "first summary" :>: arbitrary :>: ("summary", 1)+        :|: arbitrary :>: ("description", 1)+        :|: ("raw", 1)++type API =+    "get" :> Get '[JSON] String+        :<|> "zero" :> ReqBody '[JSON] String :> Post '[JSON] String+        :<|> "first" :> "second" :> ReqBody '[JSON] Int :> Post '[JSON] String+        :<|> "third" :> ReqBody '[PlainText] String :> Put '[JSON] String+        :<|> WithNamedContext "context" '[] ("time" :> QueryParams "seconds" Int :> Put '[JSON] Int)+        :<|> "capture" :> HttpVersion :> QueryFlag "flag" :> Get '[JSON] String+        :<|> "headers" :> IsSecure :> Header "first" String :> Header "second" String :> Delete '[JSON] Int+        :<|> Summary "Summary" :> "capture" :> RemoteHost :> Capture "first" String :> CaptureAll "second" Int :> Post '[JSON] Int+        :<|> Description "description" :> "fragment" :> Fragment String :> Get '[JSON] String+        :<|> Raw++generateSpec :: IO ()+generateSpec = do+    endpoints <- liftIO $ generate (Proxy @API) generators+    hspec $+        describe "generate" $ do+            it "correctly retrieves endpoint weight and method" $ do+                let gets = take 3 endpoints+                method <$> gets `shouldBe` replicate 3 (Just methodGet)+                drop 3 (method <$> endpoints)+                    `shouldBe` [ Just methodPost+                               , Just methodPut+                               , Just methodPut+                               , Just methodGet+                               , Just methodDelete+                               , Just methodPost+                               , Just methodGet+                               , Nothing+                               ]+            it "correctly retrieves endpoint names" $ do+                name <$> drop 2 endpoints+                    `shouldBe` [ "get"+                               , "first"+                               , "third"+                               , "context"+                               , "capture"+                               , "headers"+                               , "summary"+                               , "description"+                               , "raw"+                               ]++type BasicAuthSpecAPI = BasicAuth "realm" User :> Get '[JSON] User++basicAuthGenerator = fromUser :>: pure (MkUser "foo_user" "bar_pass") :>: ("basic auth", 1)+data User = MkUser T.Text T.Text++fromUser :: User -> BasicAuthData+fromUser (MkUser name pass) =+    BasicAuthData (T.encodeUtf8 name) (T.encodeUtf8 pass)++basicAuthSpec :: IO ()+basicAuthSpec =+    hspec $+        describe "BasicAuth support" $+            it "correctly produces authorization headers" $ do+                endpointHeader <- headers . head <$> generate (Proxy @BasicAuthSpecAPI) basicAuthGenerator+                let bs64 = BS8.pack "Basic " <> encode (fromString "foo_user:bar_pass")+                endpointHeader `shouldBe` [(hAuthorization, bs64)]