diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +4.1.0 +----- + +- **Breaking:** `HttpStatusCode` is now a data type (`StatusCode Int | StatusRange + StatusCodeRange`) instead of `type HttpStatusCode = Int`, so a `Responses` map can hold + OpenAPI 3.1 status-code range keys (`1XX`...`5XX`) in addition to explicit codes. A `Num` + instance keeps integer literals such as `at 200` and `setResponse 404` working unchanged. + Fixes #1. + 4.0.0 ----- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -207,11 +207,6 @@ The design and implementation strategy behind the 3.1 work is documented in **[`docs/OPENAPI31_MIGRATION_PLAN.md`](https://github.com/shinzui/openapi-hs/blob/master/docs/OPENAPI31_MIGRATION_PLAN.md)**. -## Contributing - -Bug reports, fixes, documentation improvements, and other contributions are welcome. Please open -an issue or pull request on the [GitHub issue tracker](https://github.com/shinzui/openapi-hs/issues). - ## License `openapi-hs` retains the original **BSD-3-Clause** license of the upstream diff --git a/openapi-hs.cabal b/openapi-hs.cabal --- a/openapi-hs.cabal +++ b/openapi-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: openapi-hs -version: 4.0.0 +version: 4.1.0 synopsis: OpenAPI 3.1 data model category: Web, OpenApi description: diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -92,7 +92,8 @@ -- ** Responses Responses (..), Response (..), - HttpStatusCode, + HttpStatusCode (..), + StatusCodeRange (..), Link (..), Callback (..), diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | @@ -20,6 +21,7 @@ #endif import Control.Monad (unless) import Data.Aeson.Types qualified as JSON +import Data.Char (isDigit) import Data.Data ( Constr, Data (..), @@ -792,8 +794,106 @@ } deriving stock (Eq, Show, Generic, Data, Typeable) --- | An HTTP status code keying an entry in 'Responses' (e.g. @200@, @404@). -type HttpStatusCode = Int +-- | A key in a 'Responses' map. Per the OpenAPI 3.1 specification a response +-- may be keyed either by an explicit HTTP status code (e.g. @200@, @404@) or by +-- a status-code /range/ that stands for a whole class of responses. A range is +-- written as a single leading digit @1@-@5@ followed by two literal uppercase +-- @X@ characters: @1XX@, @2XX@, @3XX@, @4XX@, @5XX@. +-- +-- The @default@ key is represented separately by '_responsesDefault' and is +-- never stored in the map, so it is not a constructor here. +-- +-- A 'Num' instance is provided so that ordinary integer literals continue to +-- denote explicit status codes: writing @200@ where an 'HttpStatusCode' is +-- expected yields @'StatusCode' 200@. Only 'fromInteger' is meaningful; the +-- arithmetic operators are defined for totality (projecting to 'Int') but have +-- no real-world meaning for status codes. +data HttpStatusCode + = -- | An explicit status code such as @200@ or @404@. + StatusCode Int + | -- | A whole class of responses, e.g. @'StatusRange' 'R4XX'@ for the @4XX@ key. + StatusRange StatusCodeRange + deriving stock (Eq, Ord, Show, Generic, Data, Typeable) + deriving anyclass (Hashable) + +-- | The five status-code range classes permitted by OpenAPI 3.1, one per +-- leading digit. @'R1XX'@ serializes as @1XX@, @'R2XX'@ as @2XX@, and so on. +data StatusCodeRange + = R1XX + | R2XX + | R3XX + | R4XX + | R5XX + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic, Data, Typeable) + deriving anyclass (Hashable) + +-- | Project an 'HttpStatusCode' onto a representative integer: explicit codes map +-- to themselves; a range maps to its hundreds value (@R1XX -> 100@, ..., @R5XX -> +-- 500@). Used only to give the 'Num' instance total arithmetic; not exported. +httpStatusCodeToInt :: HttpStatusCode -> Int +httpStatusCodeToInt (StatusCode n) = n +httpStatusCodeToInt (StatusRange r) = (fromEnum r + 1) * 100 + +-- | Integer literals denote explicit status codes (see 'HttpStatusCode'). The +-- non-'fromInteger' methods are total but not semantically meaningful. +instance Num HttpStatusCode where + fromInteger = StatusCode . fromInteger + a + b = StatusCode (httpStatusCodeToInt a + httpStatusCodeToInt b) + a - b = StatusCode (httpStatusCodeToInt a - httpStatusCodeToInt b) + a * b = StatusCode (httpStatusCodeToInt a * httpStatusCodeToInt b) + abs = StatusCode . abs . httpStatusCodeToInt + signum = StatusCode . signum . httpStatusCodeToInt + negate = StatusCode . negate . httpStatusCodeToInt + +-- | Render an 'HttpStatusCode' as the text used for a JSON object key. +renderHttpStatusCode :: HttpStatusCode -> Text +renderHttpStatusCode (StatusCode n) = Text.pack (show n) +renderHttpStatusCode (StatusRange r) = case r of + R1XX -> "1XX" + R2XX -> "2XX" + R3XX -> "3XX" + R4XX -> "4XX" + R5XX -> "5XX" + +-- | Parse a JSON object key into an 'HttpStatusCode'. Accepts a run of ASCII +-- digits as an explicit code, or the exact forms @1XX@...@5XX@ (uppercase @X@) +-- as a range. Anything else is rejected with a descriptive message. +parseHttpStatusCode :: Text -> Either String HttpStatusCode +parseHttpStatusCode t = case parseRange t of + Just r -> Right (StatusRange r) + Nothing + | not (Text.null t) && Text.all isDigit t -> + case readMaybe (Text.unpack t) of + Just n -> Right (StatusCode n) + Nothing -> Left err + | otherwise -> Left err + where + err = + "Invalid Responses key " + <> show (Text.unpack t) + <> "; expected an HTTP status code (e.g. \"200\") or a range (\"1XX\"...\"5XX\")." + parseRange x = case Text.unpack x of + [d, 'X', 'X'] -> case d of + '1' -> Just R1XX + '2' -> Just R2XX + '3' -> Just R3XX + '4' -> Just R4XX + '5' -> Just R5XX + _ -> Nothing + _ -> Nothing + +instance ToJSON HttpStatusCode where + toJSON = String . renderHttpStatusCode + toEncoding = toEncoding . renderHttpStatusCode + +instance ToJSONKey HttpStatusCode where + toJSONKey = JSON.toJSONKeyText renderHttpStatusCode + +instance FromJSON HttpStatusCode where + parseJSON = withText "HttpStatusCode" (either fail pure . parseHttpStatusCode) + +instance FromJSONKey HttpStatusCode where + fromJSONKey = FromJSONKeyTextParser (either fail pure . parseHttpStatusCode) -- | Describes a single response from an API Operation. data Response = Response diff --git a/test/Data/OpenApi/Schema/RoundtripSpec.hs b/test/Data/OpenApi/Schema/RoundtripSpec.hs --- a/test/Data/OpenApi/Schema/RoundtripSpec.hs +++ b/test/Data/OpenApi/Schema/RoundtripSpec.hs @@ -49,7 +49,21 @@ prop_schema31_roundtrip = forAll genSchema $ \s -> (decode (encode s) :: Maybe Schema) === Just s +-- | Every key the renderer can produce must parse back to the same value. +genHttpStatusCode :: Gen HttpStatusCode +genHttpStatusCode = + oneof + [ StatusCode <$> choose (100, 599), + StatusRange <$> elements [minBound .. maxBound] + ] + +prop_httpStatusCode_key_roundtrip :: Property +prop_httpStatusCode_key_roundtrip = forAll genHttpStatusCode $ \c -> + parseHttpStatusCode (renderHttpStatusCode c) === Right c + spec :: Spec -spec = +spec = do describe "Schema 3.1 round-trip" $ prop "decode . encode == Just for random 3.1 schemas" prop_schema31_roundtrip + describe "HttpStatusCode key round-trip" $ + prop "parse . render == Right for codes and ranges" prop_httpStatusCode_key_roundtrip diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -32,6 +32,40 @@ describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON + describe "Status Code Range Responses" $ statusRangeResponsesExample <=> statusRangeResponsesExampleJSON + describe "Responses with default, exact, range and $ref" $ responsesMixedExample <=> responsesMixedExampleJSON + describe "Issue #1: range status code parses" + $ it "decodes an operation whose responses include a 4XX range" + $ do + let js = + [aesonQQ| +{ + "operationId": "test_endpoint", + "responses": { + "200": { "description": "200 response" }, + "429": { "description": "too many requests" }, + "4XX": { "description": "client error" } + } +} +|] + case fromJSON js :: Result Operation of + Success op -> + (op ^. responses . at (StatusRange R4XX)) + `shouldBe` Just (Inline (mempty & description .~ "client error")) + Error e -> expectationFailure ("expected successful parse, got: " <> e) + describe "Responses key parsing" $ do + it "rejects a lowercase range key" + $ (fromJSON [aesonQQ| { "4xx": { "description": "x" } } |] :: Result Responses) + `shouldSatisfy` isError + it "rejects an out-of-range class key" + $ (fromJSON [aesonQQ| { "6XX": { "description": "x" } } |] :: Result Responses) + `shouldSatisfy` isError + it "accepts every valid range class" + $ ( fromJSON + [aesonQQ| { "1XX": {"description":"a"}, "5XX": {"description":"b"} } |] :: + Result Responses + ) + `shouldSatisfy` isSuccess describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON describe "OAuth2 Security Definitions with empty Scope" $ oAuth2SecurityDefinitionsEmptyExample <=> oAuth2SecurityDefinitionsEmptyExampleJSON @@ -55,6 +89,14 @@ main :: IO () main = hspec spec +isError :: Result a -> Bool +isError (Error _) = True +isError _ = False + +isSuccess :: Result a -> Bool +isSuccess (Success _) = True +isSuccess _ = False + -- ======================================================================= -- Info object -- ======================================================================= @@ -515,6 +557,40 @@ "IllegalInput": { "description": "Illegal input for operation." } +} +|] + +statusRangeResponsesExample :: Responses +statusRangeResponsesExample = + mempty + & at 200 ?~ Inline (mempty & description .~ "OK") + & at (StatusRange R4XX) ?~ Inline (mempty & description .~ "Client error") + +statusRangeResponsesExampleJSON :: Value +statusRangeResponsesExampleJSON = + [aesonQQ| +{ + "200": { "description": "OK" }, + "4XX": { "description": "Client error" } +} +|] + +responsesMixedExample :: Responses +responsesMixedExample = + mempty + & default_ ?~ Inline (mempty & description .~ "Unexpected error") + & at 200 ?~ Inline (mempty & description .~ "OK") + & at (StatusRange R4XX) ?~ Inline (mempty & description .~ "Client error") + & at (StatusRange R5XX) ?~ Ref (Reference "ServerError") + +responsesMixedExampleJSON :: Value +responsesMixedExampleJSON = + [aesonQQ| +{ + "default": { "description": "Unexpected error" }, + "200": { "description": "OK" }, + "4XX": { "description": "Client error" }, + "5XX": { "$ref": "#/components/responses/ServerError" } } |]