diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ -2.8.9 +2.8.7 +--- + +- Support extensions on operations (see [#245](https://github.com/GetShopTV/swagger2/pull/245)); +- Support GHC 9.6 (see [#246](https://github.com/GetShopTV/swagger2/pull/246)); + +2.8.6 --- - Support GHC 9.4 (see [#244](https://github.com/GetShopTV/swagger2/pull/244)); diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -124,12 +124,12 @@ -- $setup -- >>> import Control.Lens -- >>> import Data.Aeson +-- >>> import qualified Data.HashMap.Strict.InsOrd as IOHM -- >>> import Data.Monoid -- >>> import Data.Proxy -- >>> import GHC.Generics -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings --- >>> :set -XOverloadedLists -- >>> :set -fno-warn-missing-methods -- $howto @@ -185,8 +185,8 @@ -- -- >>> :{ -- encode $ (mempty :: Swagger) --- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ] --- & paths .~ +-- & definitions .~ IOHM.fromList [ ("User", mempty & type_ ?~ SwaggerString) ] +-- & paths .~ IOHM.fromList -- [ ("/user", mempty & get ?~ (mempty -- & produces ?~ MimeList ["application/json"] -- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) @@ -297,7 +297,6 @@ -- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic -- >>> instance ToSchema BadMixedType -- ... --- ... error: -- ... • Cannot derive Generic-based Swagger Schema for BadMixedType -- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors). -- ... Swagger does not have a good representation for these types. diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -13,6 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Data.Swagger.Internal where @@ -24,12 +25,14 @@ import Control.Applicative import Data.Aeson import qualified Data.Aeson.Types as JSON +import Data.Bifunctor (first) import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import Data.HashSet.InsOrd (InsOrdHashSet) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (mapMaybe) import Data.Monoid (Monoid (..)) import Data.Semigroup.Compat (Semigroup (..)) import Data.Scientific (Scientific) @@ -43,6 +46,7 @@ import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM import Generics.SOP.TH (deriveGeneric) @@ -297,6 +301,10 @@ -- This definition overrides any declared top-level security. -- To remove a top-level security declaration, @Just []@ can be used. , _operationSecurity :: [SecurityRequirement] + + -- | Extensions to the Swagger schema's operations. These automatically get + -- the @x-@ prefix required by the swagger specification. + , _operationExtensions :: InsOrdHashMap Text Value } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -1141,8 +1149,12 @@ toEncoding = sopSwaggerGenericToEncoding instance ToJSON Operation where - toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding + toJSON t = + case sopSwaggerGenericToJSON t of + Object obj -> Object $ obj + & KM.delete "extensions" + & KM.union (KM.fromList $ fmap (first $ K.fromText . mappend "x-") $ InsOrdHashMap.toList $ _operationExtensions t) + _ -> error "impossible: bug in generic ToJSON for Operation" instance ToJSON PathItem where toJSON = sopSwaggerGenericToJSON @@ -1310,7 +1322,22 @@ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Operation where - parseJSON = sopSwaggerGenericParseJSON + parseJSON v = do + x <- sopSwaggerGenericParseJSON @Operation v + flip (withObject "operation") v $ \obj -> pure $ x + { _operationExtensions + = InsOrdHashMap.fromList + $ mapMaybe getExtension + $ fmap (first $ K.toText) + $ KM.toList obj + } + where + getExtension :: (Text, Value) -> Maybe (Text, Value) + getExtension (prop, val) + | Text.isPrefixOf "x-" prop || Text.isPrefixOf "X-" prop + = Just (Text.drop 2 prop, val) + | otherwise = Nothing + instance FromJSON PathItem where parseJSON = sopSwaggerGenericParseJSON diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -17,6 +17,10 @@ applyTags, applyTagsFor, + -- ** Extensions + addExtensions, + addExtensionsFor, + -- ** Responses setResponse, setResponseWith, @@ -34,11 +38,13 @@ import Prelude.Compat import Control.Lens +import Data.Aeson (Value) import Data.Data.Lens import Data.List.Compat import Data.Maybe (mapMaybe) import Data.Proxy import qualified Data.Set as Set +import Data.Text (Text) import Data.Swagger.Declare import Data.Swagger.Internal @@ -46,17 +52,19 @@ import Data.Swagger.Schema import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashSet.InsOrd as InsOrdHS -- $setup -- >>> import Data.Aeson +-- >>> import qualified Data.HashMap.Strict.InsOrd as IOHM -- >>> import Data.Proxy -- >>> import Data.Time -- | Prepend path piece to all operations of the spec. -- Leading and trailing slashes are trimmed/added automatically. -- --- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)] +-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/info", mempty)] -- >>> encode $ prependPath "user/{user_id}" api ^. paths -- "{\"/user/{user_id}/info\":{}}" prependPath :: FilePath -> Swagger -> Swagger @@ -77,8 +85,8 @@ -- by both path and method. -- -- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK" --- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] --- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] +-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ ok & post ?~ ok)] +-- >>> let sub = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> encode api -- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" -- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found" @@ -108,6 +116,13 @@ applyTags :: [Tag] -> Swagger -> Swagger applyTags = applyTagsFor allOperations +addExtensions :: (Value -> Value -> Value) -> InsOrdHashMap Text Value -> Swagger -> Swagger +addExtensions = addExtensionsFor allOperations + +addExtensionsFor :: Traversal' Swagger Operation -> (Value -> Value -> Value) -> InsOrdHashMap Text Value -> Swagger -> Swagger +addExtensionsFor ops merge add swag = swag + & ops . extensions %~ InsOrdHashMap.unionWith merge add + -- | Apply tags to a part of Swagger spec and update the global -- list of tags. applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger @@ -136,7 +151,7 @@ -- -- Example: -- --- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] +-- >>> let api = (mempty :: Swagger) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse (Proxy :: Proxy Day) -- >>> encode $ api & setResponse 200 res -- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -15,6 +15,7 @@ -- library. -- -- >>> import Data.Aeson +-- >>> import qualified Data.HashMap.Strict.InsOrd as IOHM -- >>> import Optics.Core -- >>> :set -XOverloadedLabels -- @@ -22,8 +23,8 @@ -- -- >>> :{ -- encode $ (mempty :: Swagger) --- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ] --- & #paths .~ +-- & #definitions .~ IOHM.fromList [ ("User", mempty & #type ?~ SwaggerString) ] +-- & #paths .~ IOHM.fromList -- [ ("/user", mempty & #get ?~ (mempty -- & #produces ?~ MimeList ["application/json"] -- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User")) diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: swagger2 -version: 2.8.6 +version: 2.8.7 synopsis: Swagger 2.0 data model category: Web, Swagger @@ -33,7 +33,9 @@ custom-setup setup-depends: - base, Cabal, cabal-doctest >=1.0.6 && <1.1 + base < 4.19 + , Cabal < 3.11 + , cabal-doctest >=1.0.6 && <1.1 library hs-source-dirs: src @@ -60,10 +62,10 @@ -- GHC boot libraries build-depends: - base >=4.9 && <4.18 + base >=4.9 && <4.19 , bytestring >=0.10.8.1 && <0.12 , containers >=0.5.7.1 && <0.7 - , template-haskell >=2.11.1.0 && <2.20 + , template-haskell >=2.11.1.0 && <2.21 , time >=1.6.0.1 && <1.14 , transformers >=0.5.2.0 && <0.7 @@ -73,7 +75,7 @@ -- other dependencies build-depends: - base-compat-batteries >=0.11.1 && <0.13 + base-compat-batteries >=0.11.1 && <0.14 , aeson >=2.0.0.0 && <2.2 , aeson-pretty >=0.8.7 && <0.9 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -12,6 +12,7 @@ import Data.Aeson import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified Data.HashSet.InsOrd as InsOrdHS import Data.Text (Text) @@ -156,6 +157,7 @@ & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] + & extensions .~ InsOrdHashMap.fromList [("age", Number 42)] where stringSchema :: ParamLocation -> ParamOtherSchema stringSchema loc = mempty @@ -216,7 +218,8 @@ "read:pets" ] } - ] + ], + "x-age": 42 } |]