diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for servant-wrt + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-benchmark.cabal b/servant-benchmark.cabal new file mode 100644 --- /dev/null +++ b/servant-benchmark.cabal @@ -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 +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 diff --git a/src/Servant/Benchmark.hs b/src/Servant/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark.hs @@ -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 diff --git a/src/Servant/Benchmark/BasicAuth.hs b/src/Servant/Benchmark/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/BasicAuth.hs @@ -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) diff --git a/src/Servant/Benchmark/Endpoint.hs b/src/Servant/Benchmark/Endpoint.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/Endpoint.hs @@ -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" diff --git a/src/Servant/Benchmark/Generator.hs b/src/Servant/Benchmark/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/Generator.hs @@ -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) diff --git a/src/Servant/Benchmark/HasEndpoint.hs b/src/Servant/Benchmark/HasEndpoint.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/HasEndpoint.hs @@ -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 diff --git a/src/Servant/Benchmark/HasGenerator.hs b/src/Servant/Benchmark/HasGenerator.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/HasGenerator.hs @@ -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) diff --git a/src/Servant/Benchmark/ToText.hs b/src/Servant/Benchmark/ToText.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/ToText.hs @@ -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 diff --git a/src/Servant/Benchmark/Tools/Drill.hs b/src/Servant/Benchmark/Tools/Drill.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/Tools/Drill.hs @@ -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 diff --git a/src/Servant/Benchmark/Tools/Siege.hs b/src/Servant/Benchmark/Tools/Siege.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/Tools/Siege.hs @@ -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 diff --git a/src/Servant/Benchmark/Tools/Wrk.hs b/src/Servant/Benchmark/Tools/Wrk.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Benchmark/Tools/Wrk.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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)]