diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -8,4 +8,9 @@ - Fix missing dependency bounds +## 0.1.2.0 + +- Change `Generator` to an open type family +- Add `Generator` and `HasEndpoint` instances for `NoContentVerb` + ## Unreleased changes diff --git a/servant-benchmark.cabal b/servant-benchmark.cabal --- a/servant-benchmark.cabal +++ b/servant-benchmark.cabal @@ -1,77 +1,84 @@ -cabal-version: 1.12 -name: servant-benchmark -version: 0.1.1.1 -license: BSD3 -license-file: LICENSE -copyright: 2021 Kyriakos Papachrysanthou -maintainer: papachrysanthou.k@gmail.com -author: Kyriakos Papachrysanthou -homepage: https://github.com/3kyro/servant-benchmark#readme -bug-reports: https://github.com/3kyro/servant-benchmark/issues -synopsis: Generate benchmark files from a Servant API -description: - Please see the README on GitHub at +cabal-version: 1.12 -category: Web -build-type: Simple +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 861575a6df74fa9a62f3d04ddacc0e6bad1330403cfe2e203112f102af140569 + +name: servant-benchmark +version: 0.1.2.0 +synopsis: Generate benchmark 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@gmail.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 + 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 - - hs-source-dirs: src - other-modules: Paths_servant_benchmark - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - QuickCheck >=2.14.2 && <2.15, - aeson >=1.5.6.0 && <1.6, - base >=4.7 && <5, - base64-bytestring >=1.1.0.0 && <1.2, - bytestring >=0.10.12.0 && <0.11, - case-insensitive >=1.2.1.0 && <1.3, - http-media >=0.8.0.0 && <0.9, - http-types >=0.12.3 && <0.13, - servant >=0.18.2 && <0.19, - text >=1.2.4.1 && <1.3, - yaml >=0.11.5.0 && <0.12 + 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 - hs-source-dirs: test - other-modules: Paths_servant_benchmark - default-language: Haskell2010 - ghc-options: - -threaded -rtsopts -with-rtsopts=-N -fprint-potential-instances - - build-depends: - QuickCheck >=2.14.2 && <2.15, - aeson >=1.5.6.0 && <1.6, - base >=4.7 && <5, - base64-bytestring >=1.1.0.0 && <1.2, - bytestring >=0.10.12.0 && <0.11, - case-insensitive >=1.2.1.0 && <1.3, - hspec >=2.7.8 && <2.8, - http-media >=0.8.0.0 && <0.9, - http-types >=0.12.3 && <0.13, - servant >=0.18.2 && <0.19, - servant-benchmark -any, - text >=1.2.4.1 && <1.3, - yaml >=0.11.5.0 && <0.12 + 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 + , utf8-string + , yaml + default-language: Haskell2010 diff --git a/src/Servant/Benchmark/Generator.hs b/src/Servant/Benchmark/Generator.hs --- a/src/Servant/Benchmark/Generator.hs +++ b/src/Servant/Benchmark/Generator.hs @@ -131,26 +131,50 @@ 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 +type family Generator (api :: Type) + +type instance Generator (a :<|> b) = Generator a :|: Generator b + +type instance Generator (Verb (method :: k) (statusCode :: Nat) (contentTypes :: [Type]) (a :: Type)) = (T.Text, Word) + +type instance Generator (NoContentVerb (method :: k)) = (T.Text, Word) + +type instance Generator (ReqBody '[JSON] (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator (ReqBody '[PlainText] (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator (QueryParams params a :> rest) = Gen a :>: Generator rest + +type instance Generator ((sym :: Symbol) :> rest) = Generator rest + +type instance Generator (HttpVersion :> rest) = Generator rest + +type instance Generator (QueryFlag (sym :: Symbol) :> rest) = Generator rest + +type instance Generator (Capture (sym :: Symbol) String :> rest) = Gen String :>: Generator rest + +type instance Generator (Capture (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator (CaptureAll (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator (Header (sym :: Symbol) (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator (Fragment (a :: Type) :> rest) = Gen a :>: Generator rest + +type instance Generator EmptyAPI = (T.Text, Word) + +type instance Generator (RemoteHost :> rest) = Generator rest + +type instance Generator (IsSecure :> rest) = Generator rest + +type instance Generator (WithNamedContext (name :: Symbol) (sub :: [Type]) (api :: Type)) = Generator api + +type instance 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) + +type instance Generator (Description (sym :: Symbol) :> rest) = Generator rest + +type instance Generator (Summary (sym :: Symbol) :> rest) = Generator rest + +type instance Generator Raw = (T.Text, Word) diff --git a/src/Servant/Benchmark/HasEndpoint.hs b/src/Servant/Benchmark/HasEndpoint.hs --- a/src/Servant/Benchmark/HasEndpoint.hs +++ b/src/Servant/Benchmark/HasEndpoint.hs @@ -59,6 +59,22 @@ } weight _ gen = snd gen +-- Instance for common verbs that don't return content. +-- A NoContentVerb 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). + ReflectMethod method => + HasEndpoint (NoContentVerb method) + 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. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,18 +4,15 @@ {-# LANGUAGE TypeOperators #-} import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString as BS -import Data.ByteString.Base64 (decode, encode) +import Data.ByteString.Base64 (encode) import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.UTF8 (fromString) +import Data.Proxy (Proxy (..)) 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.API 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) @@ -24,6 +21,7 @@ generateSpec basicAuthSpec +generators :: Generator API generators = ("get", 3) :|: arbitrary :>: ("zero", 0) @@ -34,6 +32,7 @@ :|: pure "first value" :>: pure "second value" :>: ("headers", 1) :|: pure "first summary" :>: arbitrary :>: ("summary", 1) :|: arbitrary :>: ("description", 1) + :|: ("nocontentverb", 1) :|: ("raw", 1) type API = @@ -46,6 +45,7 @@ :<|> "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 + :<|> "nocontentverb" :> DeleteNoContent :<|> Raw generateSpec :: IO () @@ -64,6 +64,7 @@ , Just methodDelete , Just methodPost , Just methodGet + , Just methodDelete , Nothing ] it "correctly retrieves endpoint names" $ do @@ -76,17 +77,19 @@ , "headers" , "summary" , "description" + , "nocontentverb" , "raw" ] type BasicAuthSpecAPI = BasicAuth "realm" User :> Get '[JSON] User +basicAuthGenerator :: Generator BasicAuthSpecAPI 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) +fromUser (MkUser usrName pass) = + BasicAuthData (T.encodeUtf8 usrName) (T.encodeUtf8 pass) basicAuthSpec :: IO () basicAuthSpec =