diff --git a/src/Data/OpenApi/Schema/Generator.hs b/src/Data/OpenApi/Schema/Generator.hs index 9cb4014f..940cb2dc 100644 --- a/src/Data/OpenApi/Schema/Generator.hs +++ b/src/Data/OpenApi/Schema/Generator.hs @@ -8,7 +8,6 @@ import Prelude () import Prelude.Compat import Control.Lens.Operators -import Control.Monad (filterM) import Data.Aeson import Data.Aeson.Types import qualified Data.HashMap.Strict.InsOrd as M @@ -19,8 +18,10 @@ import qualified Data.Set as S import Data.OpenApi import Data.OpenApi.Declare import Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V +import GHC.Stack (HasCallStack) import Test.QuickCheck (arbitrary) import Test.QuickCheck.Gen import Test.QuickCheck.Property @@ -29,16 +30,19 @@ import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap) -- | Note: 'schemaGen' may 'error', if schema type is not specified, -- and cannot be inferred. -schemaGen :: Definitions Schema -> Schema -> Gen Value -schemaGen _ schema +schemaGen :: HasCallStack => Definitions Schema -> Schema -> Gen Value +schemaGen = schemaGenWithFormats (const Nothing) + +schemaGenWithFormats :: HasCallStack => (Format -> Maybe (Gen Text)) -> Definitions Schema -> Schema -> Gen Value +schemaGenWithFormats _ _ schema | Just cases <- schema ^. enum_ = elements cases -schemaGen defns schema +schemaGenWithFormats _ defns schema | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants) -schemaGen defns schema = +schemaGenWithFormats formatGen defns schema = case schema ^. type_ of Nothing -> case inferSchemaTypes schema of - [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType) + [ inferredType ] -> schemaGenWithFormats formatGen defns (schema & type_ ?~ inferredType) -- Gen is not MonadFail _ -> error "unable to infer schema type" Just OpenApiBoolean -> Bool <$> elements [True, False] @@ -65,12 +69,16 @@ schemaGen defns schema = minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems arrayLength <- choose (minLength', max minLength' maxLength') - generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema + generatedArray <- vectorOf arrayLength $ schemaGenWithFormats formatGen defns itemSchema return . Array $ V.fromList generatedArray OpenApiItemsArray refs -> - let itemGens = schemaGen defns . dereference defns <$> refs + let itemGens = schemaGenWithFormats formatGen defns . dereference defns <$> refs in fmap (Array . V.fromList) $ sequence itemGens - Just OpenApiString -> do + | otherwise -> error "invalid array" + Just OpenApiString + | Just gen <- formatGen =<< schema ^. format -> + String <$> gen + | otherwise -> do size <- getSize let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength @@ -90,11 +98,11 @@ schemaGen defns schema = numProps <- choose (minProps', max minProps' maxProps') let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props - let gens = schemaGen defns <$> presentProps + let gens = schemaGenWithFormats formatGen defns <$> presentProps additionalGens <- case schema ^. additionalProperties of Just (AdditionalPropertiesSchema addlSchema) -> do additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary - return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema) + return . M.fromList $ zip additionalKeys (repeat . schemaGenWithFormats formatGen defns $ dereference defns addlSchema) _ -> return [] x <- sequence $ gens <> additionalGens return . Object $ fromInsOrdHashMap x diff --git a/test/Data/OpenApi/Schema/GeneratorSpec.hs b/test/Data/OpenApi/Schema/GeneratorSpec.hs index 092673f6..fb3297f2 100644 --- a/test/Data/OpenApi/Schema/GeneratorSpec.hs +++ b/test/Data/OpenApi/Schema/GeneratorSpec.hs @@ -91,6 +91,19 @@ spec = do prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty) prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType) + describe "schemaGenWithFormats" $ do + it "supports custom string format generators" $ do + let sch = mempty + & type_ ?~ OpenApiString + & format ?~ "custom" + + let formatGen fmt = case fmt of + "custom" -> Just (pure "custom") + _ -> Nothing + + value <- generate $ schemaGenWithFormats formatGen mempty sch + value `shouldBe` String "custom" + -- ============================= -- Data types and bunk instances -- =============================