diff --git a/dhall-openapi.cabal b/dhall-openapi.cabal --- a/dhall-openapi.cabal +++ b/dhall-openapi.cabal @@ -1,6 +1,6 @@ Cabal-Version: >=1.11 Name: dhall-openapi -Version: 1.0.3 +Version: 1.0.4 Homepage: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-openapi#dhall-openapi Author: Fabrizio Ferrai Maintainer: Gabriel439@gmail.com @@ -45,7 +45,7 @@ filepath >= 1.4 && < 1.5 , -- megaparsec follows SemVer: https://github.com/mrkkrp/megaparsec/issues/469#issuecomment-927918469 megaparsec >= 7.0 && < 10 , - optparse-applicative >= 0.14.3.0 && < 0.17 , + optparse-applicative >= 0.14.3.0 && < 0.18 , parser-combinators , prettyprinter , sort , @@ -79,10 +79,10 @@ base >= 4.11.0.0 && < 5 , aeson >= 1.0.0.0 && < 2.1 , containers >= 0.5.8.0 && < 0.7 , - dhall >= 1.38.0 && < 1.41 , + dhall >= 1.38.0 && < 1.42 , prettyprinter >= 1.7.0 && < 1.8 , scientific >= 0.3.0.0 && < 0.4 , sort >= 1.0 && < 1.1 , - text >= 0.11.1.0 && < 1.3 , + text >= 0.11.1.0 && < 2.1 , vector >= 0.11.0.0 && < 0.13 Default-Language: Haskell2010 diff --git a/openapi-to-dhall/Main.hs b/openapi-to-dhall/Main.hs --- a/openapi-to-dhall/Main.hs +++ b/openapi-to-dhall/Main.hs @@ -60,6 +60,8 @@ -- | Top-level program options data Options = Options { skipDuplicates :: Bool + , preferNaturalInt :: Bool + , natIntExceptions :: [(String,String)] , prefixMap :: Data.Map.Map Prefix Dhall.Import , splits :: Data.Map.Map ModelHierarchy (Maybe ModelName) , filename :: String @@ -174,6 +176,18 @@ parseImport _ (Dhall.Note _ (Dhall.Embed l)) = pure l parseImport prefix e = fail $ "Expected a Dhall import for " <> prefix <> " not:\n" <> show e +parseNatIntExceptions :: Options.Applicative.ReadM [(String, String)] +parseNatIntExceptions = + Options.Applicative.eitherReader $ \s -> + bimap errorBundlePretty id $ result (pack s) + where + parser = do + typ <- some alphaNumChar + char '.' + fld <- some alphaNumChar + return (typ, fld) + result = parse ((Dhall.Parser.unParser parser `sepBy1` char ',') <* eof) "EXCEPTIONS" + parsePrefixMap :: Options.Applicative.ReadM (Data.Map.Map Prefix Dhall.Import) parsePrefixMap = Options.Applicative.eitherReader $ \s -> @@ -201,17 +215,28 @@ mo <- parseModel return mo return (path, model) - result = parse ((Dhall.Parser.unParser parser `sepBy1` char ',') <* eof) "MAPPING" + result = parse ((Dhall.Parser.unParser parser `sepBy1` char ',') <* eof) "SPLITS" parseOptions :: Options.Applicative.Parser Options -parseOptions = Options <$> parseSkip <*> parsePrefixMap' <*> parseSplits' <*> fileArg <*> crdArg +parseOptions = Options <$> parseSkip <*> parseNaturalInt <*> parseNatIntExceptions' <*> parsePrefixMap' <*> parseSplits' <*> fileArg <*> crdArg where parseSkip = Options.Applicative.switch ( Options.Applicative.long "skipDuplicates" <> Options.Applicative.help "Skip types with the same name when aggregating types" ) + parseNaturalInt = + Options.Applicative.switch + ( Options.Applicative.long "preferNaturalInt" + <> Options.Applicative.help "Render Swagger Integer as Dhall Natural unless negative numbers included in range" + ) + parseNatIntExceptions' = + option [] $ Options.Applicative.option parseNatIntExceptions + ( Options.Applicative.long "natIntExceptions" + <> Options.Applicative.help "List of Type.field that should be treated the opposite way to preferNaturalInt; e.g.: ContainerStateTerminated.exitCode,ContainerStateTerminated.signal" + <> Options.Applicative.metavar "EXCEPTIONS" + ) parsePrefixMap' = option Data.Map.empty $ Options.Applicative.option parsePrefixMap ( Options.Applicative.long "prefixMap" @@ -223,7 +248,7 @@ ( Options.Applicative.long "splitPaths" <> Options.Applicative.help "Specifiy path and model name pairs with paths being delimited by '.' and pairs separated by '=' for which \ - \definitions should be aritifically split with a ref: \n\ + \definitions should be artificially split with a ref: \n\ \'(com.example.v1.Certificate).spec=com.example.v1.CertificateSpec'\n\ \When the model name is omitted, a guess will be made based on the first word of the definition's \ \description. Also note that top level model names in a path must use () when the name contains '.'" @@ -280,13 +305,16 @@ let fix m = Data.Map.adjust patchCyclicImports (ModelName m) - -- Convert to Dhall types in a Map - let types = Convert.toTypes prefixMap (Convert.pathSplitter splits) + let fixedDefs = -- TODO: find a better way to deal with this cyclic import - $ fix "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1beta1.JSONSchemaProps" - $ fix "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1.JSONSchemaProps" - defs + ( fix "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1beta1.JSONSchemaProps" + . fix "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1.JSONSchemaProps" + . fix "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1beta1.JSONSchemaProps.dhall" + ) defs + -- Convert to Dhall types in a Map + let types = Convert.toTypes prefixMap (Convert.pathSplitter splits) preferNaturalInt natIntExceptions fixedDefs + -- Output to types Directory.createDirectoryIfMissing True "types" for_ (Data.Map.toList types) $ \(ModelName name, expr) -> do @@ -294,7 +322,7 @@ writeDhall path expr -- Convert from Dhall types to defaults - let defaults = Data.Map.mapMaybeWithKey (Convert.toDefault prefixMap defs) types + let defaults = Data.Map.mapMaybeWithKey (Convert.toDefault prefixMap fixedDefs) types -- Output to defaults Directory.createDirectoryIfMissing True "defaults" diff --git a/src/Dhall/Kubernetes/Convert.hs b/src/Dhall/Kubernetes/Convert.hs --- a/src/Dhall/Kubernetes/Convert.hs +++ b/src/Dhall/Kubernetes/Convert.hs @@ -162,13 +162,13 @@ many types reference other types so we need to access them to decide things like "should this key be optional" -} -toTypes :: Data.Map.Map Prefix Dhall.Import -> ([ModelName] -> Definition -> Maybe ModelName) -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr -toTypes prefixMap typeSplitter definitions = toTypes' prefixMap typeSplitter definitions Data.Map.empty +toTypes :: Data.Map.Map Prefix Dhall.Import -> ([ModelName] -> Definition -> Maybe ModelName) -> Bool -> [(String,String)] -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr +toTypes prefixMap typeSplitter preferNaturalInt natIntExceptions definitions = toTypes' prefixMap typeSplitter preferNaturalInt natIntExceptions definitions Data.Map.empty -toTypes' :: Data.Map.Map Prefix Dhall.Import -> ([ModelName] -> Definition -> Maybe ModelName) -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr -> Data.Map.Map ModelName Expr -toTypes' prefixMap typeSplitter definitions toMerge +toTypes' :: Data.Map.Map Prefix Dhall.Import -> ([ModelName] -> Definition -> Maybe ModelName) -> Bool -> [(String,String)] -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr -> Data.Map.Map ModelName Expr +toTypes' prefixMap typeSplitter preferNaturalInt natIntExceptions definitions toMerge | Data.Map.null definitions = toMerge - | otherwise = mergeNoConflicts (==) (toTypes' prefixMap typeSplitter newDefs modelMap) toMerge + | otherwise = mergeNoConflicts (==) (toTypes' prefixMap typeSplitter preferNaturalInt natIntExceptions newDefs modelMap) toMerge where -- some CRDs are equal all except for the top description. This is safe as the only usage of description @@ -176,10 +176,18 @@ equalsIgnoringDescription :: Definition -> Definition -> Bool equalsIgnoringDescription a b = a { description = description b } == b + getModelName :: ModelHierarchy -> String + getModelName hierarchy = + case hierarchy of + [] -> "" + [ModelName{..}] -> Text.unpack (last $ Text.splitOn "." unModelName) + _ -> getModelName (tail hierarchy) + convertAndAccumWithKey :: ModelHierarchy -> Data.Map.Map ModelName Definition -> ModelName -> Definition -> (Data.Map.Map ModelName Definition, Expr) convertAndAccumWithKey modelHierarchy accDefs k v = (mergeNoConflicts equalsIgnoringDescription accDefs leftOverDefs, expr) where - (expr, leftOverDefs) = convertToType (modelHierarchy ++ [k]) v + isException = ((getModelName modelHierarchy), (getModelName [k])) `elem` natIntExceptions + (expr, leftOverDefs) = (convertToType (modelHierarchy ++ [k]) v (isException /= preferNaturalInt)) (newDefs, modelMap) = Data.Map.mapAccumWithKey (convertAndAccumWithKey []) Data.Map.empty definitions @@ -190,8 +198,8 @@ -- | Convert a single Definition to a Dhall Type, yielding any definitions to be split -- Note: model hierarchy contains the modelName of of the current definition as the last entry - convertToType :: ModelHierarchy -> Definition -> (Expr, Data.Map.Map ModelName Definition) - convertToType modelHierarchy definition + convertToType :: ModelHierarchy -> Definition -> Bool -> (Expr, Data.Map.Map ModelName Definition) + convertToType modelHierarchy definition prefNatInt | Just splitModelName <- typeSplitter modelHierarchy definition = ( Dhall.Embed $ mkImport prefixMap [] ((unModelName splitModelName) <> ".dhall"), Data.Map.singleton splitModelName definition) -- If we point to a ref we just reference it via Import @@ -217,21 +225,31 @@ adaptRecordList = Dhall.Map.mapMaybe (Just . Dhall.makeRecordField) in (Dhall.Record $ adaptRecordList $ Dhall.Map.fromList $ fmap (first $ unModelName) allFields, newPropDefs) + | Just props <- additionalProperties definition + , let (mapValue, rest) = convertToType modelHierarchy props prefNatInt = + (Dhall.App Dhall.List (Dhall.Record (Dhall.Map.fromList [ ("mapKey", Dhall.makeRecordField Dhall.Text), ("mapValue", Dhall.makeRecordField mapValue) ])), rest) -- This is another way to declare an intOrString | Maybe.isJust $ intOrString definition = (intOrStringType, Data.Map.empty) -- Otherwise - if we have a 'type' - it's a basic type | Just basic <- typ definition = case basic of "object" -> (kvList, Data.Map.empty) "array" | Just item <- items definition -> - let (e, tm) = convertToType (modelHierarchy) item + let (e, tm) = convertToType (modelHierarchy) item prefNatInt in (Dhall.App Dhall.List e, tm) "string" | format definition == Just "int-or-string" -> (intOrStringType, Data.Map.empty) "string" -> (Dhall.Text, Data.Map.empty) "boolean" -> (Dhall.Bool, Data.Map.empty) - "integer" -> case (minimum_ definition, exclusiveMinimum definition) of - (Just min_, Just True) | min_ >= -1 -> (Dhall.Natural, Data.Map.empty) - (Just min_, _) | min_ >= 0 -> (Dhall.Natural, Data.Map.empty) - _ -> (Dhall.Integer, Data.Map.empty) + "integer" -> if prefNatInt then case (minimum_ definition, exclusiveMinimum definition, + maximum_ definition, exclusiveMaximum definition) of + (Just min_, Just True, _, _) | min_ < -1 -> (Dhall.Integer, Data.Map.empty) + (Just min_, _, _, _) | min_ < 0 -> (Dhall.Integer, Data.Map.empty) + (_, _, Just max_, Just True) | max_ < 1 -> (Dhall.Integer, Data.Map.empty) + (_, _, Just max_, _) | max_ < 0 -> (Dhall.Integer, Data.Map.empty) + _ -> (Dhall.Natural, Data.Map.empty) + else case (minimum_ definition, exclusiveMinimum definition) of + (Just min_, Just True) | min_ >= -1 -> (Dhall.Natural, Data.Map.empty) + (Just min_, _) | min_ >= 0 -> (Dhall.Natural, Data.Map.empty) + _ -> (Dhall.Integer, Data.Map.empty) "number" -> (Dhall.Double, Data.Map.empty) other -> error $ "Found missing Swagger type: " <> Text.unpack other -- There are empty schemas that only have a description, so we return empty record @@ -436,8 +454,11 @@ , v1JSONSchemaPropsFormat :: Maybe Text , v1JSONSchemaPropsMinimum :: Maybe Scientific , v1JSONSchemaPropsExclusiveMinimum :: Maybe Bool + , v1JSONSchemaPropsMaximum :: Maybe Scientific + , v1JSONSchemaPropsExclusiveMaximum :: Maybe Bool , v1JSONSchemaPropsItems :: Maybe Value , v1JSONSchemaPropsProperties :: Maybe (Data.Map.Map String V1JSONSchemaProps) + , v1JSONSchemaPropsAdditionalProperties :: Maybe V1JSONSchemaProps , v1JSONSchemaPropsRequired :: Maybe [Text] , v1JSONSchemaPropsType :: Maybe Text , v1JSONSchemaPropsIntOrString :: Maybe Bool @@ -454,8 +475,11 @@ , v1JSONSchemaPropsFormat = Nothing , v1JSONSchemaPropsMinimum = Nothing , v1JSONSchemaPropsExclusiveMinimum = Nothing + , v1JSONSchemaPropsMaximum = Nothing + , v1JSONSchemaPropsExclusiveMaximum = Nothing , v1JSONSchemaPropsItems = Nothing , v1JSONSchemaPropsProperties = Nothing + , v1JSONSchemaPropsAdditionalProperties = Nothing , v1JSONSchemaPropsRequired = Nothing , v1JSONSchemaPropsType = Nothing , v1JSONSchemaPropsIntOrString = Nothing @@ -519,17 +543,20 @@ propsToDefinition :: V1JSONSchemaProps -> Maybe BaseData -> Definition propsToDefinition V1JSONSchemaProps{..} basedata = Definition - { typ = v1JSONSchemaPropsType - , ref = Ref <$> v1JSONSchemaPropsRef - , format = v1JSONSchemaPropsFormat - , minimum_ = v1JSONSchemaPropsMinimum - , exclusiveMinimum = v1JSONSchemaPropsExclusiveMinimum - , description = v1JSONSchemaPropsDescription - , items = v1JSONSchemaPropsItems >>= parseMaybe parseJSON - , properties = fmap toProperties v1JSONSchemaPropsProperties - , required = fmap (Set.fromList . fmap FieldName) v1JSONSchemaPropsRequired - , baseData = basedata - , intOrString = v1JSONSchemaPropsIntOrString + { typ = v1JSONSchemaPropsType + , ref = Ref <$> v1JSONSchemaPropsRef + , format = v1JSONSchemaPropsFormat + , minimum_ = v1JSONSchemaPropsMinimum + , exclusiveMinimum = v1JSONSchemaPropsExclusiveMinimum + , maximum_ = v1JSONSchemaPropsMaximum + , exclusiveMaximum = v1JSONSchemaPropsExclusiveMaximum + , description = v1JSONSchemaPropsDescription + , items = v1JSONSchemaPropsItems >>= parseMaybe parseJSON + , properties = fmap toProperties v1JSONSchemaPropsProperties + , additionalProperties = fmap (\p -> propsToDefinition p Nothing) v1JSONSchemaPropsAdditionalProperties + , required = fmap (Set.fromList . fmap FieldName) v1JSONSchemaPropsRequired + , baseData = basedata + , intOrString = v1JSONSchemaPropsIntOrString } toProperties :: Data.Map.Map String V1JSONSchemaProps -> Data.Map.Map ModelName Definition diff --git a/src/Dhall/Kubernetes/Data.hs b/src/Dhall/Kubernetes/Data.hs --- a/src/Dhall/Kubernetes/Data.hs +++ b/src/Dhall/Kubernetes/Data.hs @@ -14,12 +14,16 @@ toRemove = Set.fromList $ ( ModelName - <$> [ "allOf" + <$> [ "additionalItems" + , "additionalProperties" + , "allOf" , "anyOf" + , "definitions" + , "dependencies" + , "items" , "not" , "oneOf" - , "additionalItems" - , "additionalProperties" - , "items" + , "properties" + , "patternProperties" ] ) diff --git a/src/Dhall/Kubernetes/Types.hs b/src/Dhall/Kubernetes/Types.hs --- a/src/Dhall/Kubernetes/Types.hs +++ b/src/Dhall/Kubernetes/Types.hs @@ -39,32 +39,38 @@ data Definition = Definition - { typ :: Maybe Text - , ref :: Maybe Ref - , format :: Maybe Text - , minimum_ :: Maybe Scientific -- Avoid shadowing with Prelude.minimum - , exclusiveMinimum :: Maybe Bool - , description :: Maybe Text - , items :: Maybe Definition - , properties :: Maybe (Map ModelName Definition) - , required :: Maybe (Set FieldName) - , baseData :: Maybe BaseData - , intOrString :: Maybe Bool + { typ :: Maybe Text + , ref :: Maybe Ref + , format :: Maybe Text + , minimum_ :: Maybe Scientific -- Avoid shadowing with Prelude.minimum + , exclusiveMinimum :: Maybe Bool + , maximum_ :: Maybe Scientific -- Avoid shadowing with Prelude.maximum + , exclusiveMaximum :: Maybe Bool + , description :: Maybe Text + , items :: Maybe Definition + , properties :: Maybe (Map ModelName Definition) + , additionalProperties :: Maybe Definition + , required :: Maybe (Set FieldName) + , baseData :: Maybe BaseData + , intOrString :: Maybe Bool } deriving (Generic, Show, Eq) instance FromJSON Definition where parseJSON = withObject "definition" $ \o -> do - typ <- o .:? "type" - ref <- o .:? "$ref" - format <- o .:? "format" - minimum_ <- o .:? "minimum" - exclusiveMinimum <- o .:? "exclusiveMinimum" - properties <- o .:? "properties" - required <- o .:? "required" - items <- o .:? "items" - description <- o .:? "description" - baseData <- fmap join $ optional (o .:? "x-kubernetes-group-version-kind") - intOrString <- o .:? "x-kubernetes-int-or-string" + typ <- o .:? "type" + ref <- o .:? "$ref" + format <- o .:? "format" + minimum_ <- o .:? "minimum" + exclusiveMinimum <- o .:? "exclusiveMinimum" + maximum_ <- o .:? "maximum" + exclusiveMaximum <- o .:? "exclusiveMaximum" + properties <- o .:? "properties" + additionalProperties <- o .:? "additionalProperties" + required <- o .:? "required" + items <- o .:? "items" + description <- o .:? "description" + baseData <- fmap join $ optional (o .:? "x-kubernetes-group-version-kind") + intOrString <- o .:? "x-kubernetes-int-or-string" pure Definition{..}