diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 --- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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} diff --git a/example/example.cabal b/example/example.cabal --- a/example/example.cabal +++ b/example/example.cabal @@ -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 diff --git a/example/src/Todo.hs b/example/src/Todo.hs --- a/example/src/Todo.hs +++ b/example/src/Todo.hs @@ -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) diff --git a/example/swagger.json b/example/swagger.json --- a/example/swagger.json +++ b/example/swagger.json @@ -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" + ] + } + } + } +} diff --git a/example/test/TodoSpec.hs b/example/test/TodoSpec.hs --- a/example/test/TodoSpec.hs +++ b/example/test/TodoSpec.hs @@ -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 diff --git a/servant-swagger.cabal b/servant-swagger.cabal --- a/servant-swagger.cabal +++ b/servant-swagger.cabal @@ -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: diff --git a/src/Servant/Swagger.hs b/src/Servant/Swagger.hs --- a/src/Servant/Swagger.hs +++ b/src/Servant/Swagger.hs @@ -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. diff --git a/src/Servant/Swagger/Internal.hs b/src/Servant/Swagger/Internal.hs --- a/src/Servant/Swagger/Internal.hs +++ b/src/Servant/Swagger/Internal.hs @@ -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) diff --git a/src/Servant/Swagger/Internal/Test.hs b/src/Servant/Swagger/Internal/Test.hs --- a/src/Servant/Swagger/Internal/Test.hs +++ b/src/Servant/Swagger/Internal/Test.hs @@ -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. diff --git a/src/Servant/Swagger/Internal/TypeLevel/API.hs b/src/Servant/Swagger/Internal/TypeLevel/API.hs --- a/src/Servant/Swagger/Internal/TypeLevel/API.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/API.hs @@ -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) diff --git a/src/Servant/Swagger/Internal/TypeLevel/Every.hs b/src/Servant/Swagger/Internal/TypeLevel/Every.hs --- a/src/Servant/Swagger/Internal/TypeLevel/Every.hs +++ b/src/Servant/Swagger/Internal/TypeLevel/Every.hs @@ -1,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 diff --git a/test/DocTest.hs b/test/DocTest.hs --- a/test/DocTest.hs +++ b/test/DocTest.hs @@ -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 diff --git a/test/Servant/SwaggerSpec.hs b/test/Servant/SwaggerSpec.hs --- a/test/Servant/SwaggerSpec.hs +++ b/test/Servant/SwaggerSpec.hs @@ -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" },