servant-swagger 1.1.11 → 1.2.3
raw patch · 19 files changed
Files
- CHANGELOG.md +17/−0
- README.md +2/−2
- Setup.hs +2/−1
- example/server/Main.hs +1/−1
- example/src/Todo.hs +42/−34
- example/test/TodoSpec.hs +10/−9
- servant-swagger.cabal +17/−17
- src/Servant/Swagger.hs +25/−22
- src/Servant/Swagger/Internal.hs +300/−213
- src/Servant/Swagger/Internal/Orphans.hs +9/−16
- src/Servant/Swagger/Internal/Test.hs +77/−59
- src/Servant/Swagger/Internal/TypeLevel.hs +9/−8
- src/Servant/Swagger/Internal/TypeLevel/API.hs +15/−14
- src/Servant/Swagger/Internal/TypeLevel/Every.hs +28/−23
- src/Servant/Swagger/Internal/TypeLevel/TMap.hs +12/−13
- src/Servant/Swagger/Test.hs +6/−5
- src/Servant/Swagger/TypeLevel.hs +7/−7
- test/Servant/SwaggerSpec.hs +75/−57
- test/doctests.hs +3/−3
CHANGELOG.md view
@@ -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 -------
README.md view
@@ -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
Setup.hs view
@@ -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"
example/server/Main.hs view
@@ -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-
example/src/Todo.hs view
@@ -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 ()
example/test/TodoSpec.hs view
@@ -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
servant-swagger.cabal view
@@ -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
src/Servant/Swagger.hs view
@@ -15,36 +15,37 @@ -- Additional utilities can also take advantage of the resulting files, such as testing tools. -- -- For more information see <http://swagger.io/ Swagger documentation>.-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
src/Servant/Swagger/Internal.hs view
@@ -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 <TODO> 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)
src/Servant/Swagger/Internal/Orphans.hs view
@@ -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
src/Servant/Swagger/Internal/Test.hs view
@@ -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)
src/Servant/Swagger/Internal/TypeLevel.hs view
@@ -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
src/Servant/Swagger/Internal/TypeLevel/API.hs view
@@ -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 = '[]-
src/Servant/Swagger/Internal/TypeLevel/Every.hs view
@@ -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))
src/Servant/Swagger/Internal/TypeLevel/TMap.hs view
@@ -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)-
src/Servant/Swagger/Test.hs view
@@ -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
src/Servant/Swagger/TypeLevel.hs view
@@ -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
test/Servant/SwaggerSpec.hs view
@@ -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
test/doctests.hs view
@@ -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