diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +1.2.3 +----- + +- Require insert-ordered-containers-0.3, swagger2-2.9 + +1.2.1 +----- + +- Add IsIn instance for NamedRoutes [#1707](https://github.com/haskell-servant/servant/pull/1707) + +1.2 +--- + +- WithResource combinator for Servant-managed resources [#1630](https://github.com/haskell-servant/servant/pull/1630) + + For servant-swagger, this meant the addition of a `HasSwagger` instance. + 1.1.9 ------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,9 +24,9 @@ ### Usage -Please refer to [haddock documentation](http://hackage.haskell.org/package/servant/servant-swagger). +Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-swagger). -Some examples can be found in [`example/` directory](/example). +Some examples can be found in [`example/` directory](/servant-swagger/example). ### Try it out diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} + module Main (main) where #ifndef MIN_VERSION_cabal_doctest @@ -8,7 +9,7 @@ #if MIN_VERSION_cabal_doctest(1,0,0) -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +import Distribution.Extra.Doctest (defaultMainWithDoctests) main :: IO () main = defaultMainWithDoctests "doctests" diff --git a/example/server/Main.hs b/example/server/Main.hs --- a/example/server/Main.hs +++ b/example/server/Main.hs @@ -2,10 +2,10 @@ import Network.Wai.Handler.Warp import Servant + import Todo main :: IO () main = do putStrLn "Running on port 8000" run 8000 $ serve (Proxy :: Proxy API) server - diff --git a/example/src/Todo.hs b/example/src/Todo.hs --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -1,33 +1,34 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + module Todo where -import Control.Lens -import Data.Aeson -import Data.Aeson.Encode.Pretty (encodePretty) +import Control.Lens +import Data.Aeson +import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.Proxy -import Data.Swagger -import Data.Text (Text) -import Data.Time (UTCTime (..), fromGregorian) -import Data.Typeable (Typeable) -import GHC.Generics -import Servant -import Servant.Swagger +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time (UTCTime (..), fromGregorian) +import Data.Typeable (Typeable) +import GHC.Generics +import Servant +import Servant.Swagger todoAPI :: Proxy TodoAPI todoAPI = Proxy -- | The API of a Todo service. -type TodoAPI - = "todo" :> Get '[JSON] [Todo] - :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId - :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo - :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId +type TodoAPI = + "todo" :> Get '[JSON] [Todo] + :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId + :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo + :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId -- | API for serving @swagger.json@. type SwaggerAPI = "swagger.json" :> Get '[JSON] Swagger @@ -37,36 +38,43 @@ -- | A single Todo entry. data Todo = Todo - { created :: UTCTime -- ^ Creation datetime. - , summary :: Text -- ^ Task summary. - } deriving (Show, Generic, Typeable) + { created :: UTCTime + -- ^ Creation datetime. + , summary :: Text + -- ^ Task summary. + } + deriving (Generic, Show, Typeable) -- | A unique Todo entry ID. newtype TodoId = TodoId Int - deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData) + deriving (FromHttpApiData, Generic, Show, ToJSON, Typeable) instance ToJSON Todo + instance FromJSON Todo instance ToSchema Todo where - declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy - & mapped.schema.description ?~ "This is some real Todo right here" - & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk") + declareNamedSchema proxy = + genericDeclareNamedSchema defaultSchemaOptions proxy + & mapped . schema . description ?~ "This is some real Todo right here" + & mapped . schema . example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk") instance ToParamSchema TodoId + instance ToSchema TodoId -- | Swagger spec for Todo API. todoSwagger :: Swagger -todoSwagger = toSwagger todoAPI - & info.title .~ "Todo API" - & info.version .~ "1.0" - & info.description ?~ "This is an API that tests swagger integration" - & info.license ?~ ("MIT" & url ?~ URL "http://mit.com") +todoSwagger = + toSwagger todoAPI + & info . title .~ "Todo API" + & info . version .~ "1.0" + & info . description ?~ "This is an API that tests swagger integration" + & info . license ?~ ("MIT" & url ?~ URL "http://mit.com") -- | Combined server of a Todo service with Swagger documentation. server :: Server API -server = return todoSwagger :<|> error "not implemented" +server = pure todoSwagger :<|> error "not implemented" -- | Output generated @swagger.json@ file for the @'TodoAPI'@. writeSwaggerJSON :: IO () diff --git a/example/test/TodoSpec.hs b/example/test/TodoSpec.hs --- a/example/test/TodoSpec.hs +++ b/example/test/TodoSpec.hs @@ -1,17 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} + module TodoSpec where -import Prelude () +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 import Prelude.Compat +import Servant.Swagger.Test +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Prelude () -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as BL8 -import Paths_example -import Servant.Swagger.Test -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Todo +import Paths_example +import Todo spec :: Spec spec = describe "Swagger" $ do diff --git a/servant-swagger.cabal b/servant-swagger.cabal --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-swagger -version: 1.1.11 +version: 1.2.3 synopsis: Generate a Swagger/OpenAPI/OAS 2.0 specification for your servant API. description: Swagger is a project used to describe and document RESTful APIs. The core of the @@ -28,11 +28,10 @@ copyright: (c) 2015-2018, Servant contributors category: Web, Servant, Swagger build-type: Custom -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 +tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 extra-source-files: README.md - , CHANGELOG.md , example/server/*.hs , example/src/*.hs , example/test/*.hs @@ -42,6 +41,7 @@ extra-doc-files: example/src/*.hs , example/test/*.hs + , CHANGELOG.md source-repository head type: git @@ -49,8 +49,8 @@ custom-setup setup-depends: - base >=4.9 && <5, - Cabal >= 1.24, + base >= 4.16.4.0 && < 4.22, + Cabal >= 3.6.3 && <4, cabal-doctest >=1.0.6 && <1.1 library @@ -71,16 +71,16 @@ hs-source-dirs: src build-depends: aeson >=1.4.2.0 && <3 , aeson-pretty >=0.8.7 && <0.9 - , base >=4.9.1.0 && <5 - , base-compat >=0.10.5 && <0.13 - , bytestring >=0.10.8.1 && <0.12 + , base >= 4.16.4.0 && < 4.22 + , base-compat >=0.10.5 && <0.15 + , bytestring >=0.11 && <0.13 , http-media >=0.7.1.3 && <0.9 - , insert-ordered-containers >=0.2.1.0 && <0.3 + , insert-ordered-containers >=0.3 && <0.4 , lens >=4.17 && <6 - , servant >=0.18.2 && <0.20 + , servant >=0.20.3 && <0.21 , singleton-bool >=0.1.4 && <0.2 - , swagger2 >=2.3.0.1 && <3 - , text >=1.2.3.0 && <2.1 + , swagger2 >=2.9 && <2.10 + , text >=1.2.3.0 && <2.2 , unordered-containers >=0.2.9.0 && <0.3 , hspec @@ -90,9 +90,9 @@ test-suite doctests ghc-options: -Wall build-depends: - base, + base < 5, directory >= 1.0, - doctest >= 0.17 && <0.21, + doctest >= 0.17 && <0.25, servant, QuickCheck, filepath @@ -106,11 +106,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10 - build-depends: base + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 + build-depends: base < 5 , base-compat , aeson >=1.4.2.0 && <3 - , hspec >=2.6.0 && <2.10 + , hspec >=2.6.0 && <2.12 , QuickCheck , lens , lens-aeson >=1.0.2 && <1.3 diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs --- a/src/Servant/Swagger.hs +++ b/src/Servant/Swagger.hs @@ -15,36 +15,37 @@ -- Additional utilities can also take advantage of the resulting files, such as testing tools. -- -- For more information see . -module Servant.Swagger ( - -- * How to use this library - -- $howto +module Servant.Swagger + ( -- * How to use this library + -- $howto - -- ** Generate @'Swagger'@ - -- $generate + -- ** Generate @'Swagger'@ + -- $generate - -- ** Annotate - -- $annotate + -- ** Annotate + -- $annotate - -- ** Test - -- $test + -- ** Test + -- $test - -- ** Serve - -- $serve + -- ** Serve + -- $serve - -- * @'HasSwagger'@ class - HasSwagger(..), + -- * @'HasSwagger'@ class + HasSwagger (..) - -- * Manipulation - subOperations, + -- * Manipulation + , subOperations - -- * Testing - validateEveryToJSON, - validateEveryToJSONWithPatternChecker, -) where + -- * Testing + , validateEveryToJSON + , validateEveryToJSONWithPatternChecker + ) +where -import Servant.Swagger.Internal -import Servant.Swagger.Test -import Servant.Swagger.Internal.Orphans () +import Servant.Swagger.Internal +import Servant.Swagger.Internal.Orphans () +import Servant.Swagger.Test -- $setup -- >>> import Control.Applicative @@ -55,6 +56,7 @@ -- >>> import Data.Typeable -- >>> import GHC.Generics -- >>> import Servant.API +-- >>> import System.Environment -- >>> import Test.Hspec -- >>> import Test.QuickCheck -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 @@ -64,6 +66,7 @@ -- >>> :set -XGeneralizedNewtypeDeriving -- >>> :set -XOverloadedStrings -- >>> :set -XTypeOperators +-- >>> setEnv "HSPEC_COLOR" "no" -- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) -- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) -- >>> instance ToJSON User diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -1,43 +1,44 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE UndecidableInstances #-} #endif module Servant.Swagger.Internal where -import Prelude () +import Control.Applicative ((<|>)) +import Control.Lens +import Data.Aeson +import Data.Foldable (toList) +import Data.HashMap.Strict.InsOrd.Compat (InsOrdHashMap) +import qualified Data.HashMap.Strict.InsOrd.Compat as InsOrdHashMap +import Data.Proxy +import Data.Singletons.Bool +import Data.Swagger hiding (Header) +import qualified Data.Swagger as Swagger +import Data.Swagger.Declare +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable +import GHC.Generics (D1, Meta (..), Rep) +import GHC.TypeLits +import Network.HTTP.Media (MediaType) import Prelude.Compat - -import Control.Applicative ((<|>)) -import Control.Lens -import Data.Aeson -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) -import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap -import Data.Foldable (toList) -import Data.Proxy -import Data.Typeable -import Data.Singletons.Bool -import Data.Swagger hiding (Header) -import qualified Data.Swagger as Swagger -import Data.Swagger.Declare -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.TypeLits -import Network.HTTP.Media (MediaType) -import Servant.API -import Servant.API.Description (FoldDescription, - reflectDescription) -import Servant.API.Modifiers (FoldRequired) +import Servant.API +import Servant.API.Description (FoldDescription, reflectDescription) +import Servant.API.Modifiers (FoldRequired) +import Prelude () -import Servant.Swagger.Internal.TypeLevel.API +import Servant.Swagger.Internal.TypeLevel.API -- | Generate a Swagger specification for a servant API. -- @@ -83,82 +84,111 @@ -- | All operations of sub API. -- This is similar to @'operationsOf'@ but ensures that operations -- indeed belong to the API at compile time. -subOperations :: (IsSubAPI sub api, HasSwagger sub) => - Proxy sub -- ^ Part of a servant API. - -> Proxy api -- ^ The whole servant API. +subOperations + :: (HasSwagger sub, IsSubAPI sub api) + => Proxy sub + -- ^ Part of a servant API. + -> Proxy api + -- ^ The whole servant API. -> Traversal' Swagger Operation subOperations sub _ = operationsOf (toSwagger sub) -- | Make a singleton Swagger spec (with only one endpoint). -- For endpoints with no content see 'mkEndpointNoContent'. -mkEndpoint :: forall a cs hs proxy method status. - (ToSchema a, AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) - => FilePath -- ^ Endpoint path. - -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response. +mkEndpoint + :: forall a cs hs proxy method status + . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method, ToSchema a) + => FilePath + -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs a)) + -- ^ Method, content-types, headers and response. -> Swagger -mkEndpoint path proxy - = mkEndpointWithSchemaRef (Just ref) path proxy - & definitions .~ defs +mkEndpoint path proxy = + mkEndpointWithSchemaRef (Just ref) path proxy + & definitions .~ defs where (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty -- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema. -mkEndpointNoContent :: forall nocontent cs hs proxy method status. - (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) - => FilePath -- ^ Endpoint path. - -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response. +mkEndpointNoContent + :: forall nocontent cs hs proxy method status + . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => FilePath + -- ^ Endpoint path. + -> proxy (Verb method status cs (Headers hs nocontent)) + -- ^ Method, content-types, headers and response. -> Swagger -mkEndpointNoContent path proxy - = mkEndpointWithSchemaRef Nothing path proxy +mkEndpointNoContent = mkEndpointWithSchemaRef Nothing -- | Like @'mkEndpoint'@ but with explicit schema reference. -- Unlike @'mkEndpoint'@ this function does not update @'definitions'@. -mkEndpointWithSchemaRef :: forall cs hs proxy method status a. - (AllAccept cs, AllToResponseHeader hs, SwaggerMethod method, KnownNat status) +mkEndpointWithSchemaRef + :: forall cs hs proxy method status a + . (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) => Maybe (Referenced Schema) -> FilePath -> proxy (Verb method status cs (Headers hs a)) -> Swagger -mkEndpointWithSchemaRef mref path _ = mempty - & paths.at path ?~ - (mempty & method ?~ (mempty - & produces ?~ MimeList responseContentTypes - & at code ?~ Inline (mempty - & schema .~ mref - & headers .~ responseHeaders))) +mkEndpointWithSchemaRef mref path _ = + mempty + & paths . at path + ?~ ( mempty + & method + ?~ ( mempty + & produces ?~ MimeList responseContentTypes + & at code + ?~ Inline + ( mempty + & schema .~ mref + & headers .~ responseHeaders + ) + ) + ) where - method = swaggerMethod (Proxy :: Proxy method) - code = fromIntegral (natVal (Proxy :: Proxy status)) + method = swaggerMethod (Proxy :: Proxy method) + code = fromIntegral (natVal (Proxy :: Proxy status)) responseContentTypes = allContentType (Proxy :: Proxy cs) - responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs) + responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs) -mkEndpointNoContentVerb :: forall proxy method. - (SwaggerMethod method) - => FilePath -- ^ Endpoint path. - -> proxy (NoContentVerb method) -- ^ Method +mkEndpointNoContentVerb + :: forall proxy method + . SwaggerMethod method + => FilePath + -- ^ Endpoint path. + -> proxy (NoContentVerb method) + -- ^ Method -> Swagger -mkEndpointNoContentVerb path _ = mempty - & paths.at path ?~ - (mempty & method ?~ (mempty - & at code ?~ Inline mempty)) +mkEndpointNoContentVerb path _ = + mempty + & paths . at path + ?~ ( mempty + & method + ?~ ( mempty + & at code ?~ Inline mempty + ) + ) where - method = swaggerMethod (Proxy :: Proxy method) - code = 204 -- hardcoded in servant-server + method = swaggerMethod (Proxy :: Proxy method) + code = 204 -- hardcoded in servant-server -- | Add parameter to every operation in the spec. addParam :: Param -> Swagger -> Swagger -addParam param = allOperations.parameters %~ (Inline param :) +addParam param = allOperations . parameters %~ (Inline param :) +-- | Add a tag to every operation in the spec. +addTag :: Text -> Swagger -> Swagger +addTag tag = allOperations . tags %~ ([tag] <>) + -- | Add accepted content types to every operation in the spec. addConsumes :: [MediaType] -> Swagger -> Swagger -addConsumes cs = allOperations.consumes %~ (<> Just (MimeList cs)) +addConsumes cs = allOperations . consumes %~ (<> Just (MimeList cs)) -- | Format given text as inline code in Markdown. markdownCode :: Text -> Text markdownCode s = "`" <> s <> "`" addDefaultResponse400 :: ParamName -> Swagger -> Swagger -addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400) +addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (pure response400) where sname = markdownCode pname description400 = "Invalid " <> sname @@ -169,27 +199,33 @@ class SwaggerMethod method where swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation) -instance SwaggerMethod 'GET where swaggerMethod _ = get -instance SwaggerMethod 'PUT where swaggerMethod _ = put -instance SwaggerMethod 'POST where swaggerMethod _ = post -instance SwaggerMethod 'DELETE where swaggerMethod _ = delete +instance SwaggerMethod 'GET where swaggerMethod _ = get + +instance SwaggerMethod 'PUT where swaggerMethod _ = put + +instance SwaggerMethod 'POST where swaggerMethod _ = post + +instance SwaggerMethod 'DELETE where swaggerMethod _ = delete + instance SwaggerMethod 'OPTIONS where swaggerMethod _ = options -instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ -instance SwaggerMethod 'PATCH where swaggerMethod _ = patch +instance SwaggerMethod 'HEAD where swaggerMethod _ = head_ + +instance SwaggerMethod 'PATCH where swaggerMethod _ = patch + instance HasSwagger (UVerb method cs '[]) where toSwagger _ = mempty -- | @since instance {-# OVERLAPPABLE #-} - ( ToSchema a, - HasStatus a, - AllAccept cs, - SwaggerMethod method, - HasSwagger (UVerb method cs as) - ) => - HasSwagger (UVerb method cs (a ': as)) + ( AllAccept cs + , HasStatus a + , HasSwagger (UVerb method cs as) + , SwaggerMethod method + , ToSchema a + ) + => HasSwagger (UVerb method cs (a ': as)) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method (StatusOf a) cs a)) @@ -200,22 +236,22 @@ -- polymorphic -- HasSwagger instance and will result in a type error -- since 'NoContent' does not have a 'ToSchema' instance. instance - ( KnownNat status, - AllAccept cs, - SwaggerMethod method, - HasSwagger (UVerb method cs as) - ) => - HasSwagger (UVerb method cs (WithStatus status NoContent ': as)) + ( AllAccept cs + , HasSwagger (UVerb method cs as) + , KnownNat status + , SwaggerMethod method + ) + => HasSwagger (UVerb method cs (WithStatus status NoContent ': as)) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs NoContent)) `combineSwagger` toSwagger (Proxy :: Proxy (UVerb method cs as)) - -- workaround for https://github.com/GetShopTV/swagger2/issues/218 -- We'd like to juse use (<>) but the instances are wrong combinePathItem :: PathItem -> PathItem -> PathItem -combinePathItem s t = PathItem +combinePathItem s t = + PathItem { _pathItemGet = _pathItemGet s <> _pathItemGet t , _pathItemPut = _pathItemPut s <> _pathItemPut t , _pathItemPost = _pathItemPost s <> _pathItemPost t @@ -227,7 +263,8 @@ } combineSwagger :: Swagger -> Swagger -> Swagger -combineSwagger s t = Swagger +combineSwagger s t = + Swagger { _swaggerInfo = _swaggerInfo s <> _swaggerInfo t , _swaggerHost = _swaggerHost s <|> _swaggerHost t , _swaggerBasePath = _swaggerBasePath s <|> _swaggerBasePath t @@ -244,15 +281,18 @@ , _swaggerExternalDocs = _swaggerExternalDocs s <|> _swaggerExternalDocs t } -instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where +instance {-# OVERLAPPABLE #-} (AllAccept cs, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Verb method status cs a) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) -- | @since 1.1.7 -instance (ToSchema a, Accept ct, KnownNat status, SwaggerMethod method) => HasSwagger (Stream method status fr ct a) where +instance (Accept ct, KnownNat status, SwaggerMethod method, ToSchema a) => HasSwagger (Stream method status fr ct a) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a))) -instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) - => HasSwagger (Verb method status cs (Headers hs a)) where +instance + {-# OVERLAPPABLE #-} + (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method, ToSchema a) + => HasSwagger (Verb method status cs (Headers hs a)) + where toSwagger = mkEndpoint "/" -- ATTENTION: do not remove this instance! @@ -262,26 +302,28 @@ instance (AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs NoContent) where toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent))) -instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) - => HasSwagger (Verb method status cs (Headers hs NoContent)) where +instance + (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method) + => HasSwagger (Verb method status cs (Headers hs NoContent)) + where toSwagger = mkEndpointNoContent "/" -instance (SwaggerMethod method) => HasSwagger (NoContentVerb method) where - toSwagger = mkEndpointNoContentVerb "/" +instance SwaggerMethod method => HasSwagger (NoContentVerb method) where + toSwagger = mkEndpointNoContentVerb "/" instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b) -- | @'Vault'@ combinator does not change our specification at all. -instance (HasSwagger sub) => HasSwagger (Vault :> sub) where +instance HasSwagger sub => HasSwagger (Vault :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) -- | @'IsSecure'@ combinator does not change our specification at all. -instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where +instance HasSwagger sub => HasSwagger (IsSecure :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) -- | @'RemoteHost'@ combinator does not change our specification at all. -instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where +instance HasSwagger sub => HasSwagger (RemoteHost :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) -- | @'Fragment'@ combinator does not change our specification at all. @@ -289,156 +331,196 @@ toSwagger _ = toSwagger (Proxy :: Proxy sub) -- | @'HttpVersion'@ combinator does not change our specification at all. -instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where +instance HasSwagger sub => HasSwagger (HttpVersion :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) -- | @'WithNamedContext'@ combinator does not change our specification at all. -instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where +instance HasSwagger sub => HasSwagger (WithNamedContext x c sub) where toSwagger _ = toSwagger (Proxy :: Proxy sub) -instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where +-- | @'WithResource'@ combinator does not change our specification at all. +instance HasSwagger sub => HasSwagger (WithResource res :> sub) where + toSwagger _ = toSwagger (Proxy :: Proxy sub) + +instance (HasSwagger sub, KnownSymbol sym) => HasSwagger (sym :> sub) where toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub)) where piece = symbolVal (Proxy :: Proxy sym) -instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (Capture' mods sym a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & prependPath capture - & addDefaultResponse400 tname +instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, ToParamSchema a, Typeable a) => HasSwagger (Capture' mods sym a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & prependPath capture + & addDefaultResponse400 tname where symbol = symbolVal (Proxy :: Proxy sym) - pname = if symbol == "" - then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) - else symbol + pname = + if symbol == "" + then camelTo2 '-' . tyConName . typeRepTyCon $ typeRep (Proxy :: Proxy a) + else symbol tname = Text.pack pname - transDesc "" = Nothing + transDesc "" = Nothing transDesc desc = Just (Text.pack desc) capture = "{" <> pname <> "}" - param = mempty - & name .~ tname - & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) - & required ?~ True - & schema .~ ParamOther (mempty - & in_ .~ ParamPath - & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + param = + mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema + .~ ParamOther + ( mempty + & in_ .~ ParamPath + & paramSchema .~ toParamSchema (Proxy :: Proxy a) + ) -- | Swagger Spec doesn't have a notion of CaptureAll, this instance is the best effort. -instance (KnownSymbol sym, Typeable a, ToParamSchema a, HasSwagger sub) => HasSwagger (CaptureAll sym a :> sub) where +instance (HasSwagger sub, KnownSymbol sym, ToParamSchema a, Typeable a) => HasSwagger (CaptureAll sym a :> sub) where toSwagger _ = toSwagger (Proxy :: Proxy (Capture sym a :> sub)) -instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Description desc :> api) where - toSwagger _ = toSwagger (Proxy :: Proxy api) - & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) +instance (HasSwagger api, KnownSymbol desc) => HasSwagger (Description desc :> api) where + toSwagger _ = + toSwagger (Proxy :: Proxy api) + & allOperations . description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) -instance (KnownSymbol desc, HasSwagger api) => HasSwagger (Summary desc :> api) where - toSwagger _ = toSwagger (Proxy :: Proxy api) - & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) +instance (HasSwagger api, KnownSymbol desc) => HasSwagger (Summary desc :> api) where + toSwagger _ = + toSwagger (Proxy :: Proxy api) + & allOperations . summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) -instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (QueryParam' mods sym a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addDefaultResponse400 tname +#if MIN_VERSION_servant(0,20,4) +instance (HasSwagger api, KnownSymbol operationId) => HasSwagger (OperationId operationId :> api) where + toSwagger _ = + toSwagger (Proxy :: Proxy api) + & allOperations . operationId %~ (Just (Text.pack (symbolVal (Proxy :: Proxy operationId))) <>) +#endif + +instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => HasSwagger (QueryParam' mods sym a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname where tname = Text.pack (symbolVal (Proxy :: Proxy sym)) - transDesc "" = Nothing + transDesc "" = Nothing transDesc desc = Just (Text.pack desc) - param = mempty - & name .~ tname - & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) - & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) - & schema .~ ParamOther sch - sch = mempty - & in_ .~ ParamQuery - & paramSchema .~ toParamSchema (Proxy :: Proxy a) + param = + mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) + & schema .~ ParamOther sch + sch = + mempty + & in_ .~ ParamQuery + & paramSchema .~ toParamSchema (Proxy :: Proxy a) -instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub) => HasSwagger (QueryParams sym a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addDefaultResponse400 tname +instance (HasSwagger sub, KnownSymbol sym, ToParamSchema a) => HasSwagger (QueryParams sym a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname where tname = Text.pack (symbolVal (Proxy :: Proxy sym)) - param = mempty - & name .~ tname - & schema .~ ParamOther sch - sch = mempty - & in_ .~ ParamQuery - & paramSchema .~ pschema - pschema = mempty -#if MIN_VERSION_swagger2(2,4,0) - & type_ ?~ SwaggerArray -#else - & type_ .~ SwaggerArray -#endif - & items ?~ SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)) + param = + mempty + & name .~ tname + & schema .~ ParamOther sch + sch = + mempty + & in_ .~ ParamQuery + & paramSchema .~ pschema -instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (QueryFlag sym :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addDefaultResponse400 tname + pschemaItems = SwaggerItemsPrimitive (Just CollectionMulti) (toParamSchema (Proxy :: Proxy a)) + pschema = mempty & type_ ?~ SwaggerArray & items ?~ pschemaItems + +instance (HasSwagger sub, KnownSymbol sym) => HasSwagger (QueryFlag sym :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname where tname = Text.pack (symbolVal (Proxy :: Proxy sym)) - param = mempty - & name .~ tname - & schema .~ ParamOther (mempty - & in_ .~ ParamQuery - & allowEmptyValue ?~ True - & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool) - & default_ ?~ toJSON False)) + param = + mempty + & name .~ tname + & schema + .~ ParamOther + ( mempty + & in_ .~ ParamQuery + & allowEmptyValue ?~ True + & paramSchema + .~ ( toParamSchema (Proxy :: Proxy Bool) + & default_ ?~ toJSON False + ) + ) -instance (KnownSymbol sym, ToParamSchema a, HasSwagger sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasSwagger (Header' mods sym a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addDefaultResponse400 tname +instance (HasSwagger sub, KnownSymbol (FoldDescription mods), KnownSymbol sym, SBoolI (FoldRequired mods), ToParamSchema a) => HasSwagger (Header' mods sym a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addDefaultResponse400 tname where tname = Text.pack (symbolVal (Proxy :: Proxy sym)) - transDesc "" = Nothing + transDesc "" = Nothing transDesc desc = Just (Text.pack desc) - param = mempty - & name .~ tname - & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) - & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) - & schema .~ ParamOther (mempty - & in_ .~ ParamHeader - & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + param = + mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) + & schema + .~ ParamOther + ( mempty + & in_ .~ ParamHeader + & paramSchema .~ toParamSchema (Proxy :: Proxy a) + ) -instance (ToSchema a, AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (ReqBody' mods cs a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addConsumes (allContentType (Proxy :: Proxy cs)) - & addDefaultResponse400 tname - & definitions %~ (<> defs) +instance (AllAccept cs, HasSwagger sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasSwagger (ReqBody' mods cs a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (allContentType (Proxy :: Proxy cs)) + & addDefaultResponse400 tname + & definitions %~ (<> defs) where tname = "body" - transDesc "" = Nothing + transDesc "" = Nothing transDesc desc = Just (Text.pack desc) (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty - param = mempty - & name .~ tname - & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) - & required ?~ True - & schema .~ ParamBody ref + param = + mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref -- | This instance is an approximation. -- -- @since 1.1.7 -instance (ToSchema a, Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods)) => HasSwagger (StreamBody' mods fr ct a :> sub) where - toSwagger _ = toSwagger (Proxy :: Proxy sub) - & addParam param - & addConsumes (toList (contentTypes (Proxy :: Proxy ct))) - & addDefaultResponse400 tname - & definitions %~ (<> defs) +instance (Accept ct, HasSwagger sub, KnownSymbol (FoldDescription mods), ToSchema a) => HasSwagger (StreamBody' mods fr ct a :> sub) where + toSwagger _ = + toSwagger (Proxy :: Proxy sub) + & addParam param + & addConsumes (toList (contentTypes (Proxy :: Proxy ct))) + & addDefaultResponse400 tname + & definitions %~ (<> defs) where tname = "body" - transDesc "" = Nothing + transDesc "" = Nothing transDesc desc = Just (Text.pack desc) (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty - param = mempty - & name .~ tname - & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) - & required ?~ True - & schema .~ ParamBody ref + param = + mempty + & name .~ tname + & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) + & required ?~ True + & schema .~ ParamBody ref +instance (HasSwagger (ToServantApi routes), KnownSymbol datatypeName, Rep (routes AsApi) ~ D1 ('MetaData datatypeName moduleName packageName isNewtype) f) => HasSwagger (NamedRoutes routes) where + toSwagger _ = addTag (Text.pack $ symbolVal (Proxy :: Proxy datatypeName)) (toSwagger (Proxy :: Proxy (ToServantApi routes))) + -- ======================================================================= -- Below are the definitions that should be in Servant.API.ContentTypes -- ======================================================================= @@ -455,10 +537,15 @@ class ToResponseHeader h where toResponseHeader :: Proxy h -> (HeaderName, Swagger.Header) -instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where - toResponseHeader _ = (hname, Swagger.Header Nothing hschema) +instance (KnownSymbol (FoldDescription mods), KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header' mods sym a) where + toResponseHeader _ = + ( hname + , Swagger.Header (transDesc $ reflectDescription (Proxy :: Proxy mods)) hschema + ) where hname = Text.pack (symbolVal (Proxy :: Proxy sym)) + transDesc "" = Nothing + transDesc desc = Just (Text.pack desc) hschema = toParamSchema (Proxy :: Proxy a) class AllToResponseHeader hs where @@ -467,7 +554,7 @@ instance AllToResponseHeader '[] where toAllResponseHeaders _ = mempty -instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where +instance (AllToResponseHeader hs, ToResponseHeader h) => AllToResponseHeader (h ': hs) where toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs where (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h) diff --git a/src/Servant/Swagger/Internal/Orphans.hs b/src/Servant/Swagger/Internal/Orphans.hs --- a/src/Servant/Swagger/Internal/Orphans.hs +++ b/src/Servant/Swagger/Internal/Orphans.hs @@ -1,27 +1,20 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Servant.Swagger.Internal.Orphans where -import Data.Proxy - (Proxy (..)) -import Data.Swagger -import Servant.Types.SourceT - (SourceT) -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -import Servant.API (WithStatus(..)) -#endif +import Data.Proxy (Proxy (..)) +import Data.Swagger +import Servant.API (WithStatus (..)) +import Servant.Types.SourceT (SourceT) -- | Pretend that 'SourceT m a' is '[a]'. -- -- @since 1.1.7 --- instance ToSchema a => ToSchema (SourceT m a) where - declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) -#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0) -- @since 1.1.11 deriving instance ToSchema a => ToSchema (WithStatus s a) -#endif diff --git a/src/Servant/Swagger/Internal/Test.hs b/src/Servant/Swagger/Internal/Test.hs --- a/src/Servant/Swagger/Internal/Test.hs +++ b/src/Servant/Swagger/Internal/Test.hs @@ -1,38 +1,38 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + module Servant.Swagger.Internal.Test where -import Data.Aeson (ToJSON (..)) -import Data.Aeson.Encode.Pretty (encodePretty', defConfig, - confCompare) -import Data.Swagger (Pattern, ToSchema, - toSchema) -import Data.Swagger.Schema.Validation -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Data.Typeable -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck (Arbitrary, Property, - counterexample, property) +import Data.Aeson (ToJSON (..)) +import Data.Aeson.Encode.Pretty (confCompare, defConfig, encodePretty') +import Data.Swagger (Pattern, ToSchema, toSchema) +import Data.Swagger.Schema.Validation +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Typeable +import Servant.API +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck (Arbitrary, Property, counterexample, property) -import Servant.API -import Servant.Swagger.Internal.TypeLevel +import Servant.Swagger.Internal.TypeLevel -- $setup -- >>> import Control.Applicative -- >>> import GHC.Generics -- >>> import Test.QuickCheck +-- >>> import System.Environment (setEnv) -- >>> :set -XDeriveGeneric -- >>> :set -XGeneralizedNewtypeDeriving -- >>> :set -XDataKinds -- >>> :set -XTypeOperators +-- >>> setEnv "HSPEC_COLOR" "no" -- | Verify that every type used with @'JSON'@ content type in a servant API -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@. @@ -76,32 +76,40 @@ -- >>> type ContactAPI = Get '[JSON] Contact -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) -- ... --- ...No instance for (Arbitrary Contact) +-- ...No instance for ...Arbitrary Contact... -- ... arising from a use of ‘validateEveryToJSON’ -- ... validateEveryToJSON - :: forall proxy api . - TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) - (BodyTypes JSON api) - => proxy api -- ^ Servant API. + :: forall proxy api + . TMap + (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) + (BodyTypes JSON api) + => proxy api + -- ^ Servant API. -> Spec -validateEveryToJSON _ = props - (Proxy :: Proxy [ToJSON, ToSchema]) - (maybeCounterExample . prettyValidateWith validateToJSON) - (Proxy :: Proxy (BodyTypes JSON api)) +validateEveryToJSON _ = + props + (Proxy :: Proxy [ToJSON, ToSchema]) + (maybeCounterExample . prettyValidateWith validateToJSON) + (Proxy :: Proxy (BodyTypes JSON api)) -- | Verify that every type used with @'JSON'@ content type in a servant API -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@. -- -- For validation without patterns see @'validateEveryToJSON'@. -validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) => - (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker. - -> proxy api -- ^ Servant API. +validateEveryToJSONWithPatternChecker + :: forall proxy api + . TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) + => (Pattern -> Text -> Bool) + -- ^ @'Pattern'@ checker. + -> proxy api + -- ^ Servant API. -> Spec -validateEveryToJSONWithPatternChecker checker _ = props - (Proxy :: Proxy [ToJSON, ToSchema]) - (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker)) - (Proxy :: Proxy (BodyTypes JSON api)) +validateEveryToJSONWithPatternChecker checker _ = + props + (Proxy :: Proxy [ToJSON, ToSchema]) + (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker)) + (Proxy :: Proxy (BodyTypes JSON api)) -- * QuickCheck-related stuff @@ -126,18 +134,23 @@ -- ... -- Finished in ... seconds -- 3 examples, 0 failures -props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs => - p cs -- ^ A list of constraints. - -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate. - -> p'' xs -- ^ A list of types. +props + :: forall p p'' cs xs + . TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs + => p cs + -- ^ A list of constraints. + -> (forall x. EveryTF cs x => x -> Property) + -- ^ Property predicate. + -> p'' xs + -- ^ A list of types. -> Spec props _ f px = sequence_ specs where specs :: [Spec] specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px - aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec - aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property) + aprop :: forall p' a. (Arbitrary a, EveryTF cs a, Show a, Typeable a) => p' a -> Spec + aprop _ = prop (show (typeRep (Proxy :: Proxy a))) (f :: a -> Property) -- | Pretty print validation errors -- together with actual JSON and Swagger Schema @@ -178,28 +191,33 @@ -- -- FIXME: this belongs in "Data.Swagger.Schema.Validation" (in @swagger2@). prettyValidateWith - :: forall a. (ToJSON a, ToSchema a) - => (a -> [ValidationError]) -> a -> Maybe String + :: forall a + . (ToJSON a, ToSchema a) + => (a -> [ValidationError]) + -> a + -> Maybe String prettyValidateWith f x = case f x of - [] -> Nothing - errors -> Just $ unlines - [ "Validation against the schema fails:" - , unlines (map (" * " ++) errors) - , "JSON value:" - , ppJSONString json - , "" - , "Swagger Schema:" - , ppJSONString (toJSON schema) - ] + [] -> Nothing + errors -> + Just $ + unlines + [ "Validation against the schema fails:" + , unlines (map (" * " ++) errors) + , "JSON value:" + , ppJSONString json + , "" + , "Swagger Schema:" + , ppJSONString (toJSON schema) + ] where ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty' ppCfg - ppCfg = defConfig { confCompare = compare } + ppCfg = defConfig{confCompare = compare} - json = toJSON x + json = toJSON x schema = toSchema (Proxy :: Proxy a) -- | Provide a counterexample if there is any. maybeCounterExample :: Maybe String -> Property -maybeCounterExample Nothing = property True +maybeCounterExample Nothing = property True maybeCounterExample (Just s) = counterexample s (property False) diff --git a/src/Servant/Swagger/Internal/TypeLevel.hs b/src/Servant/Swagger/Internal/TypeLevel.hs --- a/src/Servant/Swagger/Internal/TypeLevel.hs +++ b/src/Servant/Swagger/Internal/TypeLevel.hs @@ -1,9 +1,10 @@ -module Servant.Swagger.Internal.TypeLevel ( - module Servant.Swagger.Internal.TypeLevel.API, - module Servant.Swagger.Internal.TypeLevel.Every, - module Servant.Swagger.Internal.TypeLevel.TMap, -) where +module Servant.Swagger.Internal.TypeLevel + ( module Servant.Swagger.Internal.TypeLevel.API + , module Servant.Swagger.Internal.TypeLevel.Every + , module Servant.Swagger.Internal.TypeLevel.TMap + ) +where -import Servant.Swagger.Internal.TypeLevel.API -import Servant.Swagger.Internal.TypeLevel.Every -import Servant.Swagger.Internal.TypeLevel.TMap +import Servant.Swagger.Internal.TypeLevel.API +import Servant.Swagger.Internal.TypeLevel.Every +import Servant.Swagger.Internal.TypeLevel.TMap diff --git a/src/Servant/Swagger/Internal/TypeLevel/API.hs b/src/Servant/Swagger/Internal/TypeLevel/API.hs --- a/src/Servant/Swagger/Internal/TypeLevel/API.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module Servant.Swagger.Internal.TypeLevel.API where -import GHC.Exts (Constraint) -import Servant.API +import Data.Kind (Type) +import GHC.Exts (Constraint) +import Servant.API -- | Build a list of endpoints from an API. type family EndpointsList api where EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) - EndpointsList (e :> a) = MapSub e (EndpointsList a) + EndpointsList (e :> a) = MapSub e (EndpointsList a) EndpointsList a = '[a] -- | Check whether @sub@ is a sub API of @api@. @@ -32,7 +33,7 @@ -- | Append two type-level lists. type family AppendList xs ys where - AppendList '[] ys = ys + AppendList '[] ys = ys AppendList (x ': xs) ys = x ': AppendList xs ys type family Or (a :: Constraint) (b :: Constraint) :: Constraint where @@ -43,6 +44,7 @@ IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) IsIn (e :> a) (e :> b) = IsIn a b IsIn e e = () + IsIn e (NamedRoutes record) = IsIn e (ToServantApi record) -- | Check whether a type is a member of a list of types. -- This is a type-level analogue of @'elem'@. @@ -58,8 +60,8 @@ -- | Remove element from a type-level list. type family Remove x xs where - Remove x '[] = '[] - Remove x (x ': ys) = Remove x ys + Remove x '[] = '[] + Remove x (x ': ys) = Remove x ys Remove x (y ': ys) = y ': Remove x ys -- | Extract a list of unique "body" types for a specific content-type from a servant API. @@ -75,7 +77,7 @@ -- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body -- completely empty on responses to requests that only accept 'application/json', while -- setting the content-type in the response accordingly.) -type family BodyTypes' c api :: [*] where +type family BodyTypes' c api :: [Type] where BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[] BodyTypes' c (Verb verb b cs NoContent) = '[] BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] @@ -83,4 +85,3 @@ BodyTypes' c (e :> api) = BodyTypes' c api BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b) BodyTypes' c api = '[] - diff --git a/src/Servant/Swagger/Internal/TypeLevel/Every.hs b/src/Servant/Swagger/Internal/TypeLevel/Every.hs --- a/src/Servant/Swagger/Internal/TypeLevel/Every.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/Every.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif module Servant.Swagger.Internal.TypeLevel.Every where -import Data.Proxy -import GHC.Exts (Constraint) +import Data.Kind (Type) +import Data.Proxy +import GHC.Exts (Constraint) -import Servant.Swagger.Internal.TypeLevel.TMap +import Servant.Swagger.Internal.TypeLevel.TMap -- $setup -- >>> :set -XDataKinds @@ -48,16 +47,22 @@ -- | Apply multiple constraint constructors to a type as a class. -- -- This is different from @'EveryTF'@ in that it allows partial application. -class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where +class EveryTF cs x => Every (cs :: [Type -> Constraint]) (x :: Type) -instance Every '[] x where -instance (c x, Every cs x) => Every (c ': cs) x where +instance Every '[] x +instance (Every cs x, c x) => Every (c ': cs) x + -- | Like @'tmap'@, but uses @'Every'@ for multiple constraints. -- -- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a) -- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String] -- ["0","0.0"] -tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) => - p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a] +tmapEvery + :: forall a cs p p'' xs + . TMap (Every cs) xs + => p cs + -> (forall x p'. Every cs x => p' x -> a) + -> p'' xs + -> [a] tmapEvery _ = tmap (Proxy :: Proxy (Every cs)) diff --git a/src/Servant/Swagger/Internal/TypeLevel/TMap.hs b/src/Servant/Swagger/Internal/TypeLevel/TMap.hs --- a/src/Servant/Swagger/Internal/TypeLevel/TMap.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/TMap.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module Servant.Swagger.Internal.TypeLevel.TMap where -import Data.Proxy -import GHC.Exts (Constraint) +import Data.Proxy +import GHC.Exts (Constraint) -- $setup -- >>> :set -XDataKinds @@ -32,6 +32,5 @@ instance TMap q '[] where tmap _ _ _ = [] -instance (q x, TMap q xs) => TMap q (x ': xs) where +instance (TMap q xs, q x) => TMap q (x ': xs) where tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs) - diff --git a/src/Servant/Swagger/Test.hs b/src/Servant/Swagger/Test.hs --- a/src/Servant/Swagger/Test.hs +++ b/src/Servant/Swagger/Test.hs @@ -5,9 +5,10 @@ -- Stability: experimental -- -- Automatic tests for servant API against Swagger spec. -module Servant.Swagger.Test ( - validateEveryToJSON, - validateEveryToJSONWithPatternChecker, -) where +module Servant.Swagger.Test + ( validateEveryToJSON + , validateEveryToJSONWithPatternChecker + ) +where -import Servant.Swagger.Internal.Test +import Servant.Swagger.Internal.Test diff --git a/src/Servant/Swagger/TypeLevel.hs b/src/Servant/Swagger/TypeLevel.hs --- a/src/Servant/Swagger/TypeLevel.hs +++ b/src/Servant/Swagger/TypeLevel.hs @@ -5,11 +5,11 @@ -- Stability: experimental -- -- Useful type families for servant APIs. -module Servant.Swagger.TypeLevel ( - IsSubAPI, - EndpointsList, - BodyTypes, -) where - -import Servant.Swagger.Internal.TypeLevel +module Servant.Swagger.TypeLevel + ( IsSubAPI + , EndpointsList + , BodyTypes + ) +where +import Servant.Swagger.Internal.TypeLevel diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs --- a/test/Servant/SwaggerSpec.hs +++ b/test/Servant/SwaggerSpec.hs @@ -1,32 +1,34 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module Servant.SwaggerSpec where -import Control.Lens -import Data.Aeson (ToJSON(toJSON), Value, genericToJSON) -import Data.Aeson.QQ.Simple +import Control.Lens +import Data.Aeson (ToJSON (toJSON), Value, genericToJSON) +import Data.Aeson.QQ.Simple import qualified Data.Aeson.Types as JSON -import Data.Char (toLower) -import Data.Int (Int64) -import Data.Proxy -import Data.Swagger -import Data.Text (Text) -import Data.Time -import GHC.Generics -import Servant.API -import Servant.Swagger -import Servant.Test.ComprehensiveAPI (comprehensiveAPI) -import Test.Hspec hiding (example) +import Data.Char (toLower) +import Data.Int (Int64) +import Data.Proxy +import Data.Swagger +import Data.Text (Text) +import Data.Time +import GHC.Generics +import Servant.API +import Servant.Test.ComprehensiveAPI (comprehensiveAPI) +import Test.Hspec hiding (example) +import Servant.Swagger + #if !MIN_VERSION_swagger2(2,4,0) -import Data.Aeson.Lens (key, _Array) +import Data.Aeson.Lens (_Array, key) import qualified Data.Vector as V #endif @@ -55,20 +57,24 @@ data Todo = Todo { created :: UTCTime - , title :: String + , title :: String , summary :: Maybe String - } deriving (Generic) + } + deriving (Generic) instance ToJSON Todo + instance ToSchema Todo newtype TodoId = TodoId String deriving (Generic) + instance ToParamSchema TodoId type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo todoAPI :: Value -todoAPI = [aesonQQ| +todoAPI = + [aesonQQ| { "swagger":"2.0", "info": @@ -131,61 +137,72 @@ -- Hackage API -- ======================================================================= -type HackageAPI - = HackageUserAPI - :<|> HackagePackagesAPI +type HackageAPI = + HackageUserAPI + :<|> HackagePackagesAPI type HackageUserAPI = - "users" :> Get '[JSON] [UserSummary] - :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed + "users" :> Get '[JSON] [UserSummary] + :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed -type HackagePackagesAPI - = "packages" :> Get '[JSON] [Package] +type HackagePackagesAPI = + "packages" :> Get '[JSON] [Package] type Username = Text data UserSummary = UserSummary { summaryUsername :: Username - , summaryUserid :: Int64 -- Word64 would make sense too - } deriving (Eq, Show, Generic) + , summaryUserid :: Int64 -- Word64 would make sense too + } + deriving (Eq, Generic, Show) lowerCutPrefix :: String -> String -> String lowerCutPrefix s = map toLower . drop (length s) instance ToJSON UserSummary where - toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" } + toJSON = genericToJSON JSON.defaultOptions{JSON.fieldLabelModifier = lowerCutPrefix "summary"} instance ToSchema UserSummary where - declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy - & mapped.schema.example ?~ toJSON UserSummary - { summaryUsername = "JohnDoe" - , summaryUserid = 123 } + declareNamedSchema proxy = + genericDeclareNamedSchema defaultSchemaOptions{fieldLabelModifier = lowerCutPrefix "summary"} proxy + & mapped . schema . example + ?~ toJSON + UserSummary + { summaryUsername = "JohnDoe" + , summaryUserid = 123 + } type Group = Text data UserDetailed = UserDetailed { username :: Username - , userid :: Int64 - , groups :: [Group] - } deriving (Eq, Show, Generic) + , userid :: Int64 + , groups :: [Group] + } + deriving (Eq, Generic, Show) + instance ToSchema UserDetailed -newtype Package = Package { packageName :: Text } - deriving (Eq, Show, Generic) +newtype Package = Package {packageName :: Text} + deriving (Eq, Generic, Show) + instance ToSchema Package hackageSwaggerWithTags :: Swagger -hackageSwaggerWithTags = toSwagger (Proxy :: Proxy HackageAPI) - & host ?~ Host "hackage.haskell.org" Nothing - & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] - & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] +hackageSwaggerWithTags = + toSwagger (Proxy :: Proxy HackageAPI) + & host ?~ Host "hackage.haskell.org" Nothing + & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] + & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] where usersOps, packagesOps :: Traversal' Swagger Operation - usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) + usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) hackageAPI :: Value -hackageAPI = modifyValue [aesonQQ| +hackageAPI = + modifyValue + [aesonQQ| { "swagger":"2.0", "host":"hackage.haskell.org", @@ -350,7 +367,6 @@ modifyValue = over (key "tags" . _Array) V.reverse #endif - -- ======================================================================= -- Get/Post API (test for subOperations) -- ======================================================================= @@ -358,14 +374,16 @@ type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String getPostSwagger :: Swagger -getPostSwagger = toSwagger (Proxy :: Proxy GetPostAPI) - & applyTagsFor getOps ["get" & description ?~ "GET operations"] +getPostSwagger = + toSwagger (Proxy :: Proxy GetPostAPI) + & applyTagsFor getOps ["get" & description ?~ "GET operations"] where getOps :: Traversal' Swagger Operation getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI) getPostAPI :: Value -getPostAPI = [aesonQQ| +getPostAPI = + [aesonQQ| { "swagger":"2.0", "info":{ @@ -412,8 +430,8 @@ -- UVerb API -- ======================================================================= -data Lunch = Lunch {name :: String} - deriving (Eq, Show, Generic) +newtype Lunch = Lunch {name :: String} + deriving (Eq, Generic, Show) instance ToSchema Lunch @@ -421,7 +439,7 @@ type StatusOf Lunch = 200 data NoLunch = NoLunch - deriving (Eq, Show, Generic) + deriving (Eq, Generic, Show) instance ToSchema NoLunch diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,12 +1,12 @@ module Main where -import Build_doctests (flags, pkgs, module_sources) +import Build_doctests (flags, module_sources, pkgs) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do - traverse_ putStrLn args - doctest args + traverse_ putStrLn args + doctest args where args = flags ++ pkgs ++ module_sources