servant-swagger 1.0.3 → 1.1
raw patch · 16 files changed
+411/−161 lines, 16 filesdep +directorydep +filepathdep +insert-ordered-containersdep −Globdep ~aesondep ~basedep ~bytestringbuild-type:Customsetup-changednew-uploader
Dependencies added: directory, filepath, insert-ordered-containers
Dependencies removed: Glob
Dependency ranges changed: aeson, base, bytestring, doctest, http-media, lens, servant, swagger2, text, unordered-containers
Files
- CHANGELOG.md +10/−0
- README.md +1/−1
- Setup.hs +0/−2
- Setup.lhs +48/−0
- example/example.cabal +4/−1
- example/src/Todo.hs +16/−11
- example/swagger.json +160/−1
- example/test/TodoSpec.hs +10/−8
- servant-swagger.cabal +21/−15
- src/Servant/Swagger.hs +9/−8
- src/Servant/Swagger/Internal.hs +74/−78
- src/Servant/Swagger/Internal/Test.hs +2/−2
- src/Servant/Swagger/Internal/TypeLevel/API.hs +2/−10
- src/Servant/Swagger/Internal/TypeLevel/Every.hs +4/−0
- test/DocTest.hs +26/−4
- test/Servant/SwaggerSpec.hs +24/−20
CHANGELOG.md view
@@ -1,3 +1,13 @@+1.1+---++* Breaking changes:+ * Requires `swagger2 >= 2.1`+ * Requires `servant >= 0.5`++* Notes:+ * GHC-8.0 compatible release+ 1.0.3 ---
README.md view
@@ -27,7 +27,7 @@ Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-swagger). -Some examples can be found in [`example/` directory](/examples).+Some examples can be found in [`example/` directory](/example). ### Try it out
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,48 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , ""+ , "autogen_dir :: String"+ , "autogen_dir = " ++ show dir+ , ""+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
example/example.cabal view
@@ -20,6 +20,8 @@ Todo build-depends: base , aeson+ , aeson-pretty+ , bytestring , lens , servant , servant-server@@ -48,7 +50,8 @@ TodoSpec Paths_example build-depends: base == 4.*- , aeson >=0.9.0.1+ , base-compat >= 0.6.0+ , aeson >=0.11.2.0 , bytestring , example , hspec
example/src/Todo.hs view
@@ -6,16 +6,18 @@ {-# LANGUAGE TypeOperators #-} module Todo where -import Control.Lens-import Data.Aeson-import Data.Proxy-import Data.Text (Text)-import Data.Time (UTCTime(..), fromGregorian)-import Data.Typeable (Typeable)-import Data.Swagger-import GHC.Generics-import Servant-import Servant.Swagger+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 todoAPI :: Proxy TodoAPI todoAPI = Proxy@@ -41,7 +43,7 @@ -- | A unique Todo entry ID. newtype TodoId = TodoId Int- deriving (Show, Generic, Typeable, ToJSON, FromText)+ deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData) instance ToJSON Todo instance FromJSON Todo@@ -66,3 +68,6 @@ server :: Server API server = return todoSwagger :<|> error "not implemented" +-- | Output generated @swagger.json@ file for the @'TodoAPI'@.+writeSwaggerJSON :: IO ()+writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger)
example/swagger.json view
@@ -1,1 +1,160 @@-{"swagger":"2.0","info":{"version":"1.0","title":"Todo API","license":{"url":"http://mit.com","name":"MIT"},"description":"This is an API that tests swagger integration"},"definitions":{"Todo":{"example":{"summary":"get milk","created":"2015-12-31T00:00:00.000000000000Z"},"required":["created","summary"],"type":"object","description":"This is some real Todo right here","properties":{"summary":{"type":"string"},"created":{"$ref":"#/definitions/UTCTime"}}},"UTCTime":{"format":"yyyy-mm-ddThh:MM:ssZ","type":"string"},"TodoId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"paths":{"/todo/{id}":{"get":{"responses":{"404":{"description":"`id` not found"},"200":{"schema":{"$ref":"#/definitions/Todo"},"description":""}},"produces":["application/json"],"parameters":[{"maximum":9223372036854775807,"minimum":-9223372036854775808,"required":true,"in":"path","name":"id","type":"integer"}]},"put":{"consumes":["application/json"],"responses":{"404":{"description":"`id` not found"},"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/TodoId"},"description":""}},"produces":["application/json"],"parameters":[{"maximum":9223372036854775807,"minimum":-9223372036854775808,"required":true,"in":"path","name":"id","type":"integer"},{"required":true,"schema":{"$ref":"#/definitions/Todo"},"in":"body","name":"body"}]}},"/todo":{"post":{"consumes":["application/json"],"responses":{"400":{"description":"Invalid `body`"},"201":{"schema":{"$ref":"#/definitions/TodoId"},"description":""}},"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/Todo"},"in":"body","name":"body"}]},"get":{"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/Todo"},"type":"array"},"description":""}},"produces":["application/json"]}}}}+{+ "swagger": "2.0",+ "info": {+ "version": "1.0",+ "title": "Todo API",+ "license": {+ "url": "http://mit.com",+ "name": "MIT"+ },+ "description": "This is an API that tests swagger integration"+ },+ "definitions": {+ "Todo": {+ "example": {+ "summary": "get milk",+ "created": "2015-12-31T00:00:00Z"+ },+ "required": [+ "created",+ "summary"+ ],+ "type": "object",+ "description": "This is some real Todo right here",+ "properties": {+ "summary": {+ "type": "string"+ },+ "created": {+ "$ref": "#/definitions/UTCTime"+ }+ }+ },+ "UTCTime": {+ "format": "yyyy-mm-ddThh:MM:ssZ",+ "type": "string"+ },+ "TodoId": {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "type": "integer"+ }+ },+ "paths": {+ "/todo/{id}": {+ "get": {+ "responses": {+ "404": {+ "description": "`id` not found"+ },+ "200": {+ "schema": {+ "$ref": "#/definitions/Todo"+ },+ "description": ""+ }+ },+ "produces": [+ "application/json"+ ],+ "parameters": [+ {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "required": true,+ "in": "path",+ "name": "id",+ "type": "integer"+ }+ ]+ },+ "put": {+ "consumes": [+ "application/json"+ ],+ "responses": {+ "404": {+ "description": "`id` not found"+ },+ "400": {+ "description": "Invalid `body`"+ },+ "200": {+ "schema": {+ "$ref": "#/definitions/TodoId"+ },+ "description": ""+ }+ },+ "produces": [+ "application/json"+ ],+ "parameters": [+ {+ "maximum": 9223372036854775807,+ "minimum": -9223372036854775808,+ "required": true,+ "in": "path",+ "name": "id",+ "type": "integer"+ },+ {+ "required": true,+ "schema": {+ "$ref": "#/definitions/Todo"+ },+ "in": "body",+ "name": "body"+ }+ ]+ }+ },+ "/todo": {+ "post": {+ "consumes": [+ "application/json"+ ],+ "responses": {+ "400": {+ "description": "Invalid `body`"+ },+ "200": {+ "schema": {+ "$ref": "#/definitions/TodoId"+ },+ "description": ""+ }+ },+ "produces": [+ "application/json"+ ],+ "parameters": [+ {+ "required": true,+ "schema": {+ "$ref": "#/definitions/Todo"+ },+ "in": "body",+ "name": "body"+ }+ ]+ },+ "get": {+ "responses": {+ "200": {+ "schema": {+ "items": {+ "$ref": "#/definitions/Todo"+ },+ "type": "array"+ },+ "description": ""+ }+ },+ "produces": [+ "application/json"+ ]+ }+ }+ }+}
example/test/TodoSpec.hs view
@@ -1,15 +1,17 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module TodoSpec where -import Control.Applicative-import Data.Aeson+import Prelude ()+import Prelude.Compat++import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as BL8-import Servant.Swagger.Test-import Test.Hspec-import Test.QuickCheck-import Test.QuickCheck.Instances ()-import Todo-import Paths_example+import Paths_example+import Servant.Swagger.Test+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import Todo spec :: Spec spec = describe "Swagger" $ do
servant-swagger.cabal view
@@ -1,5 +1,5 @@ name: servant-swagger-version: 1.0.3+version: 1.1 synopsis: Generate Swagger specification for your servant API. description: Please see README.md homepage: https://github.com/haskell-servant/servant-swagger@@ -10,7 +10,7 @@ maintainer: nickolay.kudasov@gmail.com copyright: (c) 2015-2016, Servant contributors category: Web-build-type: Simple+build-type: Custom cabal-version: >=1.10 extra-source-files: README.md@@ -44,22 +44,28 @@ Servant.Swagger.Internal.TypeLevel.Every Servant.Swagger.Internal.TypeLevel.TMap hs-source-dirs: src- build-depends: aeson- , base >=4.7 && <5- , bytestring- , http-media- , lens- , servant- , swagger2 >= 2.0.1 && <3- , text- , unordered-containers+ build-depends: aeson >=0.11.2.0 && <0.12+ , base >=4.7.0.0 && <4.10+ , bytestring >=0.10.4.0 && <0.11+ , http-media >=0.6.3 && <0.7+ , insert-ordered-containers >=0.1.0.0 && <0.2+ , lens >=4.7.0.1 && <4.15+ , servant >=0.5 && <0.8+ , swagger2 >=2.1 && <2.2+ , text >=1.2.0.6 && <1.3+ , unordered-containers >=0.2.5.1 && <0.3 , hspec , QuickCheck default-language: Haskell2010 -test-suite doctest- build-depends: base, doctest, Glob+test-suite doctests+ ghc-options: -Wall+ build-depends:+ base,+ directory >= 1.0,+ doctest >= 0.11 && <0.12,+ filepath default-language: Haskell2010 hs-source-dirs: test main-is: DocTest.hs@@ -70,7 +76,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs- build-depends: base == 4.*+ build-depends: base , aeson , aeson-qq >=0.8.1 , hspec@@ -78,7 +84,7 @@ , lens , servant , servant-swagger- , swagger2 >= 2 && <3+ , swagger2 , text , time other-modules:
src/Servant/Swagger.hs view
@@ -42,8 +42,8 @@ validateEveryToJSONWithPatternChecker, ) where -import Servant.Swagger.Internal-import Servant.Swagger.Test+import Servant.Swagger.Internal+import Servant.Swagger.Test -- $setup -- >>> import Control.Applicative@@ -55,6 +55,7 @@ -- >>> import Servant.API -- >>> import Test.Hspec -- >>> import Test.QuickCheck+-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 -- >>> :set -XDataKinds -- >>> :set -XDeriveDataTypeable -- >>> :set -XDeriveGeneric@@ -96,8 +97,8 @@ -- $generate -- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@: ----- >>> encode $ toSwagger (Proxy :: Proxy UserAPI)--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"+-- >>> BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI)+-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} -- -- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas. --@@ -111,14 +112,14 @@ -- We can add this information using field lenses from @"Data.Swagger"@: -- -- >>> :{--- encode $ toSwagger (Proxy :: Proxy UserAPI)+-- BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI) -- & info.title .~ "User API" -- & info.version .~ "1.0" -- & info.description ?~ "This is an API for the Users service" -- & info.license ?~ "MIT" -- & host ?~ "example.com" -- :}--- "{\"swagger\":\"2.0\",\"host\":\"example.com\",\"info\":{\"version\":\"1.0\",\"title\":\"User API\",\"license\":{\"name\":\"MIT\"},\"description\":\"This is an API for the Users service\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"+-- {"swagger":"2.0","info":{"version":"1.0","title":"User API","license":{"name":"MIT"},"description":"This is an API for the Users service"},"host":"example.com","paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}} -- -- It is also useful to annotate or modify certain endpoints. -- @'subOperations'@ provides a convenient way to zoom into a part of an API.@@ -132,11 +133,11 @@ -- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI) -- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI) -- >>> :{--- encode $ toSwagger (Proxy :: Proxy UserAPI)+-- BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI) -- & applyTagsFor getOps ["get" & description ?~ "GET operations"] -- & applyTagsFor postOps ["post" & description ?~ "POST operations"] -- :}--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}],\"tags\":[\"get\"]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"201\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}],\"tags\":[\"post\"]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"tags\":[\"get\"]}}},\"tags\":[{\"name\":\"get\",\"description\":\"GET operations\"},{\"name\":\"post\",\"description\":\"POST operations\"}]}"+-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"tags":["get"],"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"tags":["post"],"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"tags":["get"],"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}},"tags":[{"name":"get","description":"GET operations"},{"name":"post","description":"POST operations"}]} -- -- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.
src/Servant/Swagger/Internal.hs view
@@ -25,6 +25,8 @@ import qualified Data.Swagger as Swagger import Data.Swagger hiding (Header) import Data.Swagger.Declare+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Text (Text) import qualified Data.Text as Text import GHC.TypeLits@@ -80,39 +82,48 @@ -> Traversal' Swagger Operation subOperations sub _ = operationsOf (toSwagger sub) -mkEndpoint :: forall a cs hs proxy _verb. (ToSchema a, AllAccept cs, AllToResponseHeader hs)- => FilePath- -> Lens' PathItem (Maybe Operation)- -> HttpStatusCode- -> proxy (_verb cs (Headers hs a))+-- | Make a singleton Swagger spec (with only one endpoint).+-- For endpoints with no content see 'mkEndpointNoContent'.+mkEndpoint :: forall a cs hs proxy 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. -> Swagger-mkEndpoint path verb code proxy- = mkEndpointWithSchemaRef (Just ref) path verb code proxy+mkEndpoint path proxy+ = mkEndpointWithSchemaRef (Just ref) path proxy & definitions .~ defs where (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty -noContentEndpoint :: forall cs proxy verb. (AllAccept cs)- => FilePath- -> Lens' PathItem (Maybe Operation)- -> proxy (verb cs ())+-- | Make a singletone 'Swagger' spec (with only one endpoint) and with no content schema.+mkEndpointNoContent :: forall nocontent cs hs proxy 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. -> Swagger-noContentEndpoint path verb _ = mkEndpointWithSchemaRef Nothing path verb 204 (Proxy :: Proxy (verb cs (Headers '[] ())))+mkEndpointNoContent path proxy+ = mkEndpointWithSchemaRef Nothing path proxy -mkEndpointWithSchemaRef :: forall cs hs proxy verb a. (AllAccept cs, AllToResponseHeader hs)+-- | 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) => Maybe (Referenced Schema) -> FilePath- -> Lens' PathItem (Maybe Operation)- -> HttpStatusCode- -> proxy (verb cs (Headers hs a))+ -> proxy (Verb method status cs (Headers hs a)) -> Swagger-mkEndpointWithSchemaRef mref path verb code _ = mempty+mkEndpointWithSchemaRef mref path _ = mempty & paths.at path ?~- (mempty & verb ?~ (mempty- & produces ?~ MimeList (allContentType (Proxy :: Proxy cs))+ (mempty & method ?~ (mempty+ & produces ?~ MimeList contentTypes & at code ?~ Inline (mempty & schema .~ mref- & headers .~ toAllResponseHeaders (Proxy :: Proxy hs))))+ & headers .~ responseHeaders)))+ where+ method = swaggerMethod (Proxy :: Proxy method)+ code = fromIntegral (natVal (Proxy :: Proxy status))+ contentTypes = allContentType (Proxy :: Proxy cs)+ responseHeaders = toAllResponseHeaders (Proxy :: Proxy hs) -- | Add parameter to every operation in the spec. addParam :: Param -> Swagger -> Swagger@@ -142,73 +153,58 @@ alter400 = description %~ (<> (" or " <> sname)) response400 = mempty & description .~ description400 --- -------------------------------------------------------------------------- DELETE--- -------------------------------------------------------------------------instance OVERLAPPABLE_ (ToSchema a, AllAccept cs) => HasSwagger (Delete cs a) where- toSwagger _ = toSwagger (Proxy :: Proxy (Delete cs (Headers '[] a)))--instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Delete cs (Headers hs a)) where- toSwagger = mkEndpoint "/" delete 200--instance AllAccept cs => HasSwagger (Delete cs ()) where- toSwagger = noContentEndpoint "/" delete---- -------------------------------------------------------------------------- GET--- -------------------------------------------------------------------------instance OVERLAPPABLE_ (ToSchema a, AllAccept cs) => HasSwagger (Get cs a) where- toSwagger _ = toSwagger (Proxy :: Proxy (Get cs (Headers '[] a)))--instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Get cs (Headers hs a)) where- toSwagger = mkEndpoint "/" get 200--instance AllAccept cs => HasSwagger (Get cs ()) where- toSwagger = noContentEndpoint "/" get---- -------------------------------------------------------------------------- PATCH--- -------------------------------------------------------------------------instance OVERLAPPABLE_ (ToSchema a, AllAccept cs) => HasSwagger (Patch cs a) where- toSwagger _ = toSwagger (Proxy :: Proxy (Patch cs (Headers '[] a)))+-- | Methods, available for Swagger.+class SwaggerMethod method where+ swaggerMethod :: proxy method -> Lens' PathItem (Maybe Operation) -instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Patch cs (Headers hs a)) where- toSwagger = mkEndpoint "/" patch 200+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 AllAccept cs => HasSwagger (Patch cs ()) where- toSwagger = noContentEndpoint "/" patch+instance OVERLAPPABLE_ (ToSchema a, AllAccept cs, KnownNat status, SwaggerMethod method) => HasSwagger (Verb method status cs a) where+ toSwagger _ = toSwagger (Proxy :: Proxy (Verb method status cs (Headers '[] a))) --- -------------------------------------------------------------------------- PUT--- -----------------------------------------------------------------------+instance OVERLAPPABLE_ (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)+ => HasSwagger (Verb method status cs (Headers hs a)) where+ toSwagger = mkEndpoint "/" -instance OVERLAPPABLE_ (ToSchema a, AllAccept cs) => HasSwagger (Put cs a) where- toSwagger _ = toSwagger (Proxy :: Proxy (Put cs (Headers '[] a)))+-- ATTENTION: do not remove this instance!+-- A similar instance above will always use the more general+-- polymorphic -- HasSwagger instance and will result in a type error+-- since 'NoContent' does not have a 'ToSchema' instance.+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 (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Put cs (Headers hs a)) where- toSwagger = mkEndpoint "/" put 200+instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, SwaggerMethod method)+ => HasSwagger (Verb method status cs (Headers hs NoContent)) where+ toSwagger = mkEndpointNoContent "/" -instance AllAccept cs => HasSwagger (Put cs ()) where- toSwagger = noContentEndpoint "/" put+instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where+ toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b) --- -------------------------------------------------------------------------- POST--- -----------------------------------------------------------------------+-- | @'Vault'@ combinator does not change our specification at all.+instance (HasSwagger sub) => HasSwagger (Vault :> sub) where+ toSwagger _ = toSwagger (Proxy :: Proxy sub) -instance OVERLAPPABLE_ (ToSchema a, AllAccept cs) => HasSwagger (Post cs a) where- toSwagger _ = toSwagger (Proxy :: Proxy (Post cs (Headers '[] a)))+-- | @'IsSecure'@ combinator does not change our specification at all.+instance (HasSwagger sub) => HasSwagger (IsSecure :> sub) where+ toSwagger _ = toSwagger (Proxy :: Proxy sub) -instance (ToSchema a, AllAccept cs, AllToResponseHeader hs) => HasSwagger (Post cs (Headers hs a)) where- toSwagger = mkEndpoint "/" post 201+-- | @'RemoteHost'@ combinator does not change our specification at all.+instance (HasSwagger sub) => HasSwagger (RemoteHost :> sub) where+ toSwagger _ = toSwagger (Proxy :: Proxy sub) -instance AllAccept cs => HasSwagger (Post cs ()) where- toSwagger = noContentEndpoint "/" post+-- | @'HttpVersion'@ combinator does not change our specification at all.+instance (HasSwagger sub) => HasSwagger (HttpVersion :> sub) where+ toSwagger _ = toSwagger (Proxy :: Proxy sub) -instance (HasSwagger a, HasSwagger b) => HasSwagger (a :<|> b) where- toSwagger _ = toSwagger (Proxy :: Proxy a) <> toSwagger (Proxy :: Proxy b)+-- | @'WithNamedContext'@ combinator does not change our specification at all.+instance (HasSwagger sub) => HasSwagger (WithNamedContext x c sub) where+ toSwagger _ = toSwagger (Proxy :: Proxy sub) instance (KnownSymbol sym, HasSwagger sub) => HasSwagger (sym :> sub) where toSwagger _ = prependPath piece (toSwagger (Proxy :: Proxy sub))@@ -320,13 +316,13 @@ hschema = toParamSchema (Proxy :: Proxy a) class AllToResponseHeader hs where- toAllResponseHeaders :: Proxy hs -> HashMap HeaderName Swagger.Header+ toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header instance AllToResponseHeader '[] where toAllResponseHeaders _ = mempty instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where- toAllResponseHeaders _ = HashMap.insert hname header hdrs+ toAllResponseHeaders _ = InsOrdHashMap.insert hname header hdrs where (hname, header) = toResponseHeader (Proxy :: Proxy h) hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
src/Servant/Swagger/Internal/Test.hs view
@@ -67,8 +67,8 @@ -- >>> type ContactAPI = Get '[JSON] Contact -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) -- ...--- No instance for (Arbitrary Contact)--- arising from a use of ‘validateEveryToJSON’+-- ...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.
src/Servant/Swagger/Internal/TypeLevel/API.hs view
@@ -73,16 +73,8 @@ -- | Extract a list of "body" types for a specific content-type from a servant API. -- To extract unique types see @'BodyTypes'@. type family BodyTypes' c api :: [*] where- BodyTypes' c (Delete cs (Headers hdrs a)) = AddBodyType c cs a '[]- BodyTypes' c (Get cs (Headers hdrs a)) = AddBodyType c cs a '[]- BodyTypes' c (Patch cs (Headers hdrs a)) = AddBodyType c cs a '[]- BodyTypes' c (Post cs (Headers hdrs a)) = AddBodyType c cs a '[]- BodyTypes' c (Put cs (Headers hdrs a)) = AddBodyType c cs a '[]- BodyTypes' c (Delete cs a) = AddBodyType c cs a '[]- BodyTypes' c (Get cs a) = AddBodyType c cs a '[]- BodyTypes' c (Patch cs a) = AddBodyType c cs a '[]- BodyTypes' c (Post cs a) = AddBodyType c cs a '[]- BodyTypes' c (Put cs a) = AddBodyType c cs a '[]+ BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[]+ BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] BodyTypes' c (ReqBody cs a :> api) = AddBodyType c cs a (BodyTypes' c api) BodyTypes' c (e :> api) = BodyTypes' c api BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b)
src/Servant/Swagger/Internal/TypeLevel/Every.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}@@ -12,6 +13,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif module Servant.Swagger.Internal.TypeLevel.Every where import Data.Proxy
test/DocTest.hs view
@@ -1,8 +1,30 @@-module Main (main) where+module Main where -import System.FilePath.Glob (glob)-import Test.DocTest (doctest)+import Build_doctests (autogen_dir, deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest main :: IO ()-main = glob "src/**/*.hs" >>= doctest+main = getSources >>= \sources -> doctest $+ "-isrc"+ : ("-i" ++ autogen_dir)+ : "-optP-include"+ : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")+ : "-hide-all-packages"+ : map ("-package="++) deps ++ sources +getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
test/Servant/SwaggerSpec.hs view
@@ -1,25 +1,26 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-} module Servant.SwaggerSpec where -import Control.Lens-import Data.Aeson+import Control.Lens+import Data.Aeson+import Data.Aeson.QQ import qualified Data.Aeson.Types as JSON-import Data.Aeson.QQ-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 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.Swagger+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)+import Test.Hspec hiding (example) checkAPI :: HasSwagger api => Proxy api -> Value -> IO () checkAPI proxy = checkSwagger (toSwagger proxy)@@ -32,6 +33,9 @@ it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI it "Hackage API (with tags)" $ checkSwagger hackageSwaggerWithTags hackageAPI it "GetPost API (test subOperations)" $ checkSwagger getPostSwagger getPostAPI+ it "Comprehensive API" $ do+ let _x = toSwagger comprehensiveAPI+ True `shouldBe` True -- type-level test main :: IO () main = hspec spec@@ -123,7 +127,7 @@ type HackageUserAPI = "users" :> Get '[JSON] [UserSummary]- :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed+ :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed type HackagePackagesAPI = "packages" :> Get '[JSON] [Package]@@ -351,7 +355,7 @@ "/":{ "post":{ "responses":{- "201":{+ "200":{ "schema":{ "type":"string" },