Add support for explicit splitting of definitions

The motivation behind this is better user experience when dealing
with Kubernetes CRDs. CRDs in an openapi definition are expressed
as one massive definition rather than the Kubernetes builtin types
which rarely nest and instead make use of references within openapi.
These references are desirable as it makes it more manageable to
sparsely define resources utilizing the nested defaults as you go down
the structure.

Unfortunately it looks like support for references wrt CRDs is unlikely
to be supported in the near future:

kubernetes/kubernetes#62872

As a workaround, this adds a new option `--splitPaths` that takes a path
and an optional new model name. The path roughly emulates the idea
behind `kubectl explain` but I ended up using the `~` character instead
of `.` such that the full parent model name could still be used without
ambiguities. During type conversion any matches of path will cause a
Dhall reference to be injected with the nested definition being pushed
back on the stack of definitions to convert. The top level model name
can either be specified on the command line via `=com.some.ModelName` or
be guessed in the case the CRD author follows the best practice of using
the field name as the first word in the description.

Some future work that might need exploring related to this are:
1. Allow specifying `splitPaths` from a file
2. Clean up which types get accumulated into the `typesUnion`. I noticed
   while doing this that all? top level definitions are being dumped
   into this union where really it should only be top level definitions
   that have an `apiVersion` and `kind`
3. See if the `mergeNoConflicts` function needs to be improved such that
   it takes semantic equality (traversing imports) into account.

dhall-openapi/openapi-to-dhall/Main.hs

@@ -17,6 +17,8 @@ import Text.Megaparsec
  , errorBundlePretty
  , parse
  , some
+ , try
+ , optional
  , (<|>)
  )
 import Text.Megaparsec.Char (alphaNumChar, char)
@@ -25,6 +27,7 @@ import Dhall.Kubernetes.Data (patchCyclicImports)
 import Dhall.Kubernetes.Types
  ( DuplicateHandler
  , ModelName (..)
+ , ModelPath
  , Prefix
  , Swagger (..)
  )
@@ -55,6 +58,7 @@ import qualified Text.Megaparsec.Char.Lexer as Megaparsec.Lexer
 data Options = Options
  { skipDuplicates :: Bool
  , prefixMap :: Data.Map.Map Prefix Dhall.Import
+ , splits :: Data.Map.Map ModelPath (Maybe ModelName)
  , filename :: String
  , crd :: Bool
  }
@@ -181,8 +185,23 @@ parsePrefixMap =
  return (pack prefix, imp)
  result = parse (Dhall.Parser.unParser parser `sepBy1` char ',') "MAPPING"
 
+parseSplits :: Options.Applicative.ReadM (Data.Map.Map ModelPath (Maybe ModelName))
+parseSplits =
+ Options.Applicative.eitherReader $ \s ->
+ bimap errorBundlePretty Data.Map.fromList $ result (pack s)
+ where
+ parser = do
+ path <- some (alphaNumChar <|> char '.' <|> char '-' <|> char '~')
+ model <- optional . try $ do
+ char '='
+ mo <- some (alphaNumChar <|> char '.' <|> char '-')
+ return (ModelName $ pack mo)
+ return (pack path, model)
+ result = parse (Dhall.Parser.unParser parser `sepBy1` char ',') "MAPPING"
+
+
 parseOptions :: Options.Applicative.Parser Options
-parseOptions = Options <$> parseSkip <*> parsePrefixMap' <*> fileArg <*> crdArg
+parseOptions = Options <$> parseSkip <*> parsePrefixMap' <*> parseSplits' <*> fileArg <*> crdArg
  where
  parseSkip =
  Options.Applicative.switch
@@ -195,6 +214,16 @@ parseOptions = Options <$> parseSkip <*> parsePrefixMap' <*> fileArg <*> crdArg
  <> Options.Applicative.help "Specify prefix mappings as 'prefix1=importBase1,prefix2=importBase2,...'"
  <> Options.Applicative.metavar "MAPPING"
  )
+ parseSplits' =
+ option Data.Map.empty $ Options.Applicative.option parseSplits
+ ( 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\
+ \'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"
+ <> Options.Applicative.metavar "SPLITS"
+ )
  fileArg = Options.Applicative.strArgument
  ( Options.Applicative.help "The input file to read"
  <> Options.Applicative.metavar "FILE"
@@ -247,7 +276,7 @@ main = do
  let fix m = Data.Map.adjust patchCyclicImports (ModelName m)
 
  -- Convert to Dhall types in a Map
- let types = Convert.toTypes prefixMap
+ let types = Convert.toTypes prefixMap (Convert.pathSplitter splits)
  -- 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"

dhall-openapi/src/Dhall/Kubernetes/Convert.hs

@@ -8,13 +8,14 @@ module Dhall.Kubernetes.Convert
  , getImportsMap
  , mkImport
  , toDefinition
+ , pathSplitter
  ) where
 
 import Control.Applicative (empty)
 import Data.Aeson
 import Data.Aeson.Types (Parser, parseMaybe)
 import Data.Bifunctor (first, second)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe, isJust)
 import Data.Set (Set)
 import Data.Text (Text)
 import Dhall.Kubernetes.Types
@@ -23,31 +24,37 @@ import GHC.Generics (Generic, Rep)
 import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.Map.Strict as Data.Map
+import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
 import qualified Data.Sort as Sort
 import qualified Data.Text as Text
+import qualified Data.Tuple as Tuple
 import qualified Dhall.Core as Dhall
 import qualified Dhall.Map
 import qualified Dhall.Optics
 
+modelsToText :: ModelHierarchy -> [Text]
+modelsToText = List.map (\ (ModelName unModelName) -> unModelName)
+
+-- | Creates a path of a given hierarchy of models (separated by @~@) that can be used for textual matching
+modelsToPath :: ModelHierarchy -> ModelPath
+modelsToPath = Text.intercalate "~" . modelsToText
+
 -- | Get all the required fields for a model
 -- See https://kubernetes.io/docs/concepts/overview/working-with-objects/kubernetes-objects/#required-fields
 -- TLDR: because k8s API allows PUTS etc with partial data,
 -- it's not clear from the data types OR the API which
 -- fields are required for A POST...
-requiredFields :: Maybe ModelName -> Maybe (Set FieldName) -> Set FieldName
-requiredFields maybeName required
+requiredFields :: ModelHierarchy -> Maybe (Set FieldName) -> Set FieldName
+requiredFields modelHierarchy required
  = Set.difference
  (List.foldr Set.union (fromMaybe Set.empty required) [alwaysRequired, toAdd])
  toRemove
  where
+ hierarchyAsText = modelsToPath modelHierarchy
  alwaysRequired = Set.fromList $ FieldName <$> [ "apiVersion", "kind", "metadata"]
- toAdd = fromMaybe Set.empty $ do
- name <- maybeName
- Data.Map.lookup name requiredConstraints
- toRemove = fromMaybe Set.empty $ do
- name <- maybeName
- Data.Map.lookup name notRequiredConstraints
+ toAdd = fromMaybe Set.empty $ Data.Map.lookup hierarchyAsText requiredConstraints
+ toRemove = fromMaybe Set.empty $ Data.Map.lookup hierarchyAsText notRequiredConstraints
 
  -- | Some models require keys that are not in the required set,
  -- but are in the docs or just work
@@ -56,13 +63,13 @@ requiredFields maybeName required
  -- | Some models should not require some keys, and this is not
  -- in the Swagger spec but just in the docs
  notRequiredConstraints = Data.Map.fromList
- [ ( ModelName "io.k8s.api.core.v1.ObjectFieldSelector"
+ [ ( "io.k8s.api.core.v1.ObjectFieldSelector"
  , Set.fromList [ FieldName "apiVersion" ]
  )
- , ( ModelName "io.k8s.apimachinery.pkg.apis.meta.v1.StatusDetails"
+ , ( "io.k8s.apimachinery.pkg.apis.meta.v1.StatusDetails"
  , Set.fromList [ FieldName "kind" ]
  )
- , ( ModelName "io.k8s.api.core.v1.PersistentVolumeClaim"
+ , ( "io.k8s.api.core.v1.PersistentVolumeClaim"
  , Set.fromList [ FieldName "apiVersion", FieldName "kind" ]
  )
  , ( ModelName "io.k8s.api.batch.v1beta1.JobTemplateSpec"
@@ -111,63 +118,121 @@ namespacedObjectFromImport _ = Nothing
 toTextLit :: Text -> Expr
 toTextLit str = Dhall.TextLit (Dhall.Chunks [] str)
 
+-- | Merge maps and error on conflicts
+mergeNoConflicts :: (Ord k, Eq a, Show a, Show k) => Data.Map.Map k a -> Data.Map.Map k a -> Data.Map.Map k a
+mergeNoConflicts = Data.Map.unionWithKey
+ (\key left right ->
+ if left == right 
+ then left 
+ else error ("Cannot merge differing values " ++ show left ++ " and " ++ show right ++ " for key " ++ show key))
+
+{- | Extract the 'ModelName' to be used when splitting a definition.
+
+ This is considered a guess as it does not work with all types. Currently it uses the first word from the description
+ appended to the largest prefix before the last @.@ of the parent.
+-}
+guessModelNameForSplit :: ModelHierarchy -> Definition -> Maybe ModelName
+guessModelNameForSplit models definition = ModelName <$> ((<>) <$> toPrepend <*> firstWordOfDesc)
+ where
+ toPrepend :: Maybe Text.Text
+ toPrepend = (Tuple.fst . Text.breakOnEnd (Text.pack ".") <$> (Maybe.listToMaybe $ modelsToText models))
+
+ firstWordOfDesc :: Maybe Text.Text
+ firstWordOfDesc = (Text.words <$> (description definition) >>= Maybe.listToMaybe)
+
+{- | Given the @pathsAndModels@ Map provides a function to be used with 'toTypes' to split types at mostly arbitrary points
+
+ The @pathsAndModels@ argument takes the form of a path to an optional 'ModelName'. Paths are of the format noted by
+ 'modelsToPath'. If a 'ModelName' is provided as a value for the given path, it will be returned (to be then used as
+ the 'ModelName' for the nested definition. If no 'ModelName' is provided, 'guessModelNameForSplit' will try to guess.
+ If that fails, 'Nothing' will be returned such that no split will be done by 'toTypes'
+ 
+ Currently not all split points in for nested definitions are supported (in fact only types with a properties
+ attribute are currently supported).
+-}
+pathSplitter :: Data.Map.Map ModelPath (Maybe ModelName) -> ModelHierarchy -> Definition -> Maybe ModelName
+pathSplitter pathsAndModels modelHierarchy definition
+ | (Maybe.isJust $ properties definition) && Maybe.isJust model = model
+ | otherwise = Nothing
+ where
+ hierarchyAsText = modelsToPath modelHierarchy
+ model = case Data.Map.lookup hierarchyAsText pathsAndModels of
+ Just (Just m) -> Just m
+ Just (Nothing) -> guessModelNameForSplit modelHierarchy definition
+ Nothing -> Nothing
 
 {-| Converts all the Swagger definitions to Dhall Types
 
  Note: we cannot do 1-to-1 conversion and we need the whole Map because
  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 -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr
-toTypes prefixMap definitions = memo
- where
- memo = Data.Map.mapWithKey (\k -> convertToType (Just k)) definitions
-
- kvList = Dhall.App Dhall.List $ Dhall.Record $ Dhall.Map.fromList
- [ ("mapKey", Dhall.makeRecordField Dhall.Text), ("mapValue", Dhall.makeRecordField Dhall.Text) ]
- intOrStringType = Dhall.Union $ Dhall.Map.fromList $ fmap (second Just)
- [ ("Int", Dhall.Natural), ("String", Dhall.Text) ]
-
- -- | Convert a single Definition to a Dhall Type
- -- Note: we have the ModelName only if this is a top-level import
- convertToType :: Maybe ModelName -> Definition -> Expr
- convertToType maybeModelName Definition{..} = case (ref, typ, properties, intOrString) of
- -- If we point to a ref we just reference it via Import
- (Just r, _, _, _) -> Dhall.Embed $ mkImport prefixMap [] (pathFromRef r <> ".dhall")
- -- Otherwise - if we have 'properties' - it's an object
- (_, _, Just props, _) ->
- let
- shouldBeRequired :: Maybe ModelName -> FieldName -> Bool
- shouldBeRequired maybeParent field = Set.member field requiredNames
- where
- requiredNames = requiredFields maybeParent required
-
- (required', optional') = Data.Map.partitionWithKey
- (\k _ -> shouldBeRequired maybeModelName (FieldName (unModelName k)))
- -- TODO: labelize
- $ Data.Map.map (convertToType Nothing) props
-
- allFields
- = Data.Map.toList required'
- <> fmap (second $ Dhall.App Dhall.Optional) (Data.Map.toList optional')
-
- adaptRecordList = Dhall.Map.mapMaybe (Just . Dhall.makeRecordField)
-
- in Dhall.Record $ adaptRecordList $ Dhall.Map.fromList $ fmap (first $ unModelName) allFields
- (_, _, _, Just _) -> intOrStringType
- -- Otherwise - if we have a 'type' - it's a basic type
- (_, Just basic, _, _) -> case basic of
- "object" -> kvList
- "array" | Just item <- items -> Dhall.App Dhall.List (convertToType Nothing item)
- "string" | format == Just "int-or-string" -> intOrStringType
- "string" -> Dhall.Text
- "boolean" -> Dhall.Bool
- "integer" -> Dhall.Natural
- "number" -> Dhall.Double
- other -> error $ "Found missing Swagger type: " <> Text.unpack other
- -- There are empty schemas that only have a description, so we return empty record
- _ -> Dhall.Record mempty
-
+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) -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr -> Data.Map.Map ModelName Expr
+toTypes' prefixMap typeSplitter definitions toMerge
+ | Data.Map.null definitions = toMerge
+ | otherwise = mergeNoConflicts (toTypes' prefixMap typeSplitter newDefs modelMap) toMerge
+ where
+
+ convertAndAccumWithKey :: ModelHierarchy -> Data.Map.Map ModelName Definition -> ModelName -> Definition -> (Data.Map.Map ModelName Definition, Expr)
+ convertAndAccumWithKey modelHierarchy accDefs k v = (mergeNoConflicts accDefs leftOverDefs, expr)
+ where
+ (expr, leftOverDefs) = convertToType (modelHierarchy ++ [k]) v
+
+ (newDefs, modelMap) = Data.Map.mapAccumWithKey (convertAndAccumWithKey []) Data.Map.empty definitions
+
+ kvList = Dhall.App Dhall.List $ Dhall.Record $ Dhall.Map.fromList
+ [ ("mapKey", Dhall.makeRecordField Dhall.Text), ("mapValue", Dhall.makeRecordField Dhall.Text) ]
+ intOrStringType = Dhall.Union $ Dhall.Map.fromList $ fmap (second Just)
+ [ ("Int", Dhall.Natural), ("String", Dhall.Text) ]
+
+ -- | 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
+ | 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
+ | Just r <- ref definition = ( Dhall.Embed $ mkImport prefixMap [] (pathFromRef r <> ".dhall"), Data.Map.empty)
+ | Just props <- properties definition =
+ let
+ shouldBeRequired :: ModelHierarchy -> FieldName -> Bool
+ shouldBeRequired hierarchy field = Set.member field requiredNames
+ where
+ requiredNames = requiredFields hierarchy (required definition)
+
+ (newPropDefs, propModelMap) = Data.Map.mapAccumWithKey (convertAndAccumWithKey modelHierarchy) Data.Map.empty props
+
+ (required', optional') = Data.Map.partitionWithKey
+ (\k _ -> shouldBeRequired modelHierarchy (FieldName (unModelName k)))
+ -- TODO: labelize
+ $ propModelMap
+
+ allFields
+ = Data.Map.toList required'
+ <> fmap (second $ Dhall.App Dhall.Optional) (Data.Map.toList optional')
+
+ adaptRecordList = Dhall.Map.mapMaybe (Just . Dhall.makeRecordField)
+
+ in (Dhall.Record $ adaptRecordList $ Dhall.Map.fromList $ fmap (first $ unModelName) allFields, newPropDefs)
+ -- This is another way to declare an intOrString
+ | 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
+ 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" -> (Dhall.Natural, 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
+ | otherwise = (Dhall.Record mempty, Data.Map.empty)
 
 -- | Convert a Dhall Type to its default value
 toDefault

dhall-openapi/src/Dhall/Kubernetes/Types.hs

@@ -21,6 +21,9 @@ type DuplicateHandler = (Text, [ModelName]) -> Maybe ModelName
 
 type Prefix = Text
 
+type ModelHierarchy = [ModelName]
+type ModelPath = Text
+
 {-| Type for the Swagger specification.
 
 There is such a type defined in the `swagger2` package, but Kubernetes' OpenAPI
@@ -45,7 +48,7 @@ data Definition = Definition
  , required :: Maybe (Set FieldName)
  , baseData :: Maybe BaseData
  , intOrString :: Maybe Bool
- } deriving (Generic, Show)
+ } deriving (Generic, Show, Eq)
 
 instance FromJSON Definition where
  parseJSON = withObject "definition" $ \o -> do
@@ -62,13 +65,12 @@ instance FromJSON Definition where
 
 
 newtype Ref = Ref { unRef :: Text }
- deriving (Generic, Show, FromJSON)
+ deriving (Generic, Show, FromJSON, Eq)
 
 
 newtype ModelName = ModelName { unModelName :: Text }
  deriving (Generic, Show, Ord, FromJSONKey, Eq, Pretty)
 
-
 newtype FieldName = FieldName { unFieldName :: Text }
  deriving (Generic, Show, FromJSON, FromJSONKey, Ord, Eq, Pretty)
 
@@ -90,7 +92,7 @@ For example for a v1 Deployment we have
 data BaseData = BaseData
  { kind :: Text
  , apiVersion :: Text
- } deriving (Generic, Show)
+ } deriving (Generic, Show, Eq)
 
 instance FromJSON BaseData where
  parseJSON = withArray "array of values" $ \arr -> withObject "baseData" (\o -> do