dhall-openapi (empty) → 1.0.0
raw patch · 7 files changed
+1136/−0 lines, 7 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, dhall, dhall-openapi, directory, filepath, megaparsec, optparse-applicative, parser-combinators, prettyprinter, scientific, sort, text, vector
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- dhall-openapi.cabal +87/−0
- openapi-to-dhall/Main.hs +350/−0
- src/Dhall/Kubernetes/Convert.hs +537/−0
- src/Dhall/Kubernetes/Data.hs +25/−0
- src/Dhall/Kubernetes/Types.hs +108/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2019 Fabrizio Ferrai+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dhall-openapi.cabal view
@@ -0,0 +1,87 @@+Cabal-Version: >=1.10+Name: dhall-openapi+Version: 1.0.0+Homepage: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-openapi#dhall-openapi+Author: Fabrizio Ferrai+Maintainer: Gabriel439@gmail.com+Copyright: 2019 Fabrizio Ferrai+License: BSD3+License-File: LICENSE+Build-Type: Simple+Category: Compiler+Synopsis: Convert an OpenAPI specification to a Dhall package+Description:+ This package provides an `openapi-to-dhall` program that converts an+ OpenAPI specification to a Dhall package containing types, defaults, and+ schemas for that API.++Source-Repository head+ Type: git+ Location: https://github.com/dhall-lang/dhall-haskell/tree/master/dhall-openapi++Executable openapi-to-dhall+ Main-Is: Main.hs+ Hs-Source-Dirs:+ openapi-to-dhall+ Default-Extensions:+ DuplicateRecordFields+ GeneralizedNewtypeDeriving+ LambdaCase+ RecordWildCards+ ScopedTypeVariables+ OverloadedStrings+ FlexibleInstances+ ConstraintKinds+ ApplicativeDo+ TupleSections+ Ghc-Options: -Wall+ Build-Depends:+ base ,+ aeson ,+ containers ,+ directory >= 1.3.0.0 && < 1.4 ,+ dhall ,+ dhall-openapi ,+ filepath >= 1.4 && < 1.5 ,+ megaparsec >= 7.0 && < 9.1 ,+ optparse-applicative >= 0.14.3.0 && < 0.17 ,+ parser-combinators , + prettyprinter ,+ sort ,+ text ,+ vector+ Default-Language: Haskell2010++Library+ Exposed-Modules:+ Dhall.Kubernetes.Convert+ Dhall.Kubernetes.Data+ Dhall.Kubernetes.Types+ Hs-Source-Dirs:+ src+ Default-Extensions:+ DeriveDataTypeable+ DeriveGeneric+ DerivingStrategies+ DuplicateRecordFields+ GeneralizedNewtypeDeriving+ LambdaCase+ RecordWildCards+ ScopedTypeVariables+ OverloadedStrings+ FlexibleInstances+ ConstraintKinds+ ApplicativeDo+ TupleSections+ Ghc-Options: -Wall+ Build-Depends:+ base >= 4.11.0.0 && < 5 ,+ aeson >= 1.0.0.0 && < 1.6 ,+ containers >= 0.5.8.0 && < 0.7 ,+ dhall >= 1.38.0 && < 1.39 ,+ 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 ,+ vector >= 0.11.0.0 && < 0.13+ Default-Language: Haskell2010
+ openapi-to-dhall/Main.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import Control.Applicative.Combinators (option, sepBy1)+import Data.Aeson (decodeFileStrict, eitherDecodeFileStrict)+import Data.Bifunctor (bimap)+import Data.Foldable (for_)+import Data.Text (Text, pack, unpack)+import Data.Void (Void)+import Dhall.Core (Expr (..))+import Dhall.Format (Format (..))+import Numeric.Natural (Natural)+import Text.Megaparsec+ ( Parsec+ , errorBundlePretty+ , parse+ , some+ , optional+ , (<|>)+ , eof+ )+import Text.Megaparsec.Char (alphaNumChar, char)++import Dhall.Kubernetes.Data (patchCyclicImports)+import Dhall.Kubernetes.Types+ ( DuplicateHandler+ , ModelName (..)+ , ModelHierarchy+ , Prefix+ , Swagger (..)+ )+import System.FilePath ((</>))++import qualified Data.List as List+import qualified Data.Map.Strict as Data.Map+import qualified Data.Ord as Ord+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Prettyprint.Doc as Pretty+import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText+import qualified Dhall.Core as Dhall+import qualified Dhall.Format+import qualified Dhall.Kubernetes.Convert as Convert+import qualified Dhall.Kubernetes.Types as Types+import qualified Dhall.Map+import qualified Dhall.Parser+import qualified Dhall.Util+import qualified GHC.IO.Encoding+import qualified Options.Applicative+import qualified System.IO+import qualified System.Directory as Directory+import qualified Text.Megaparsec as Megaparsec+import qualified Text.Megaparsec.Char.Lexer as Megaparsec.Lexer++-- | Top-level program options+data Options = Options+ { skipDuplicates :: Bool+ , prefixMap :: Data.Map.Map Prefix Dhall.Import+ , splits :: Data.Map.Map ModelHierarchy (Maybe ModelName)+ , filename :: String+ , crd :: Bool+ }++-- | Write and format a Dhall expression to a file+writeDhall :: FilePath -> Types.Expr -> IO ()+writeDhall path expr = do+ putStrLn $ "Writing file '" <> path <> "'"+ Text.writeFile path $ pretty expr <> "\n"++ let chosenCharacterSet = Nothing -- Infer from input++ let censor = Dhall.Util.NoCensor++ let outputMode = Dhall.Util.Write++ let input =+ Dhall.Util.PossiblyTransitiveInputFile+ path+ Dhall.Util.NonTransitive++ let formatOptions = Dhall.Format.Format{..}++ Dhall.Format.format formatOptions++-- | Pretty print things+pretty :: Pretty.Pretty a => a -> Text+pretty = PrettyText.renderStrict+ . Pretty.layoutPretty Pretty.defaultLayoutOptions+ . Pretty.pretty++data Stability = Alpha Natural | Beta Natural | Production deriving (Eq, Ord)++data Version = Version+ { stability :: Stability+ , version :: Natural+ } deriving (Eq, Ord)++parseStability :: Parsec Void Text Stability+parseStability = parseAlpha <|> parseBeta <|> parseProduction+ where+ parseAlpha = do+ _ <- "alpha"+ n <- Megaparsec.Lexer.decimal+ return (Alpha n)++ parseBeta = do+ _ <- "beta"+ n <- Megaparsec.Lexer.decimal+ return (Beta n)++ parseProduction = do+ return Production++parseVersion :: Parsec Void Text Version+parseVersion = Megaparsec.try parseSuffix <|> parsePrefix+ where+ parseComponent = do+ Megaparsec.takeWhile1P (Just "not a period") (/= '.')++ parseSuffix = do+ _ <- "v"+ version <- Megaparsec.Lexer.decimal+ stability <- parseStability+ _ <- "."+ _ <- parseComponent+ Megaparsec.eof+ return Version{..}++ parsePrefix = do+ _ <- parseComponent+ _ <- "."+ parseVersion++getVersion :: ModelName -> Maybe Version+getVersion ModelName{..} =+ case Megaparsec.parse parseVersion "" unModelName of+ Left _ -> Nothing+ Right version -> Just version++-- https://github.com/dhall-lang/dhall-kubernetes/issues/112+data Autoscaling = AutoscalingV1 | AutoscalingV2beta1 | AutoscalingV2beta2+ deriving (Eq, Ord)++getAutoscaling :: ModelName -> Maybe Autoscaling+getAutoscaling ModelName{..}+ | Text.isPrefixOf "io.k8s.api.autoscaling.v1" unModelName =+ Just AutoscalingV1+ | Text.isPrefixOf "io.k8s.api.autoscaling.v2beta1" unModelName =+ Just AutoscalingV2beta1+ | Text.isPrefixOf "io.k8s.api.autoscaling.v2beta2" unModelName =+ Just AutoscalingV2beta2+ | otherwise =+ Nothing++isK8sNative :: ModelName -> Bool+isK8sNative ModelName{..} = Text.isPrefixOf "io.k8s." unModelName++preferStableResource :: DuplicateHandler+preferStableResource (_, names) = do+ let issue112 = Ord.comparing getAutoscaling+ let k8sOverCrd = Ord.comparing isK8sNative+ let defaultComparison = Ord.comparing getVersion+ let comparison = issue112 <> k8sOverCrd <> defaultComparison+ return (List.maximumBy comparison names)++skipDuplicatesHandler :: DuplicateHandler+skipDuplicatesHandler = const Nothing++parseImport :: String -> Types.Expr -> Dhall.Parser.Parser Dhall.Import+parseImport _ (Dhall.Note _ (Dhall.Embed l)) = pure l+parseImport prefix e = fail $ "Expected a Dhall import for " <> prefix <> " not:\n" <> show e++parsePrefixMap :: Options.Applicative.ReadM (Data.Map.Map Prefix Dhall.Import)+parsePrefixMap =+ Options.Applicative.eitherReader $ \s ->+ bimap errorBundlePretty Data.Map.fromList $ result (pack s)+ where+ parser = do+ prefix <- some (alphaNumChar <|> char '.')+ char '='+ e <- Dhall.Parser.expr+ imp <- parseImport prefix e+ return (pack prefix, imp)+ result = parse ((Dhall.Parser.unParser parser `sepBy1` char ',') <* eof) "MAPPING"++parseSplits :: Options.Applicative.ReadM (Data.Map.Map ModelHierarchy (Maybe ModelName))+parseSplits =+ Options.Applicative.eitherReader $ \s ->+ bimap errorBundlePretty Data.Map.fromList $ result (pack s)+ where+ parseModelInner = some (alphaNumChar <|> char '-' <|> char '.')+ parseModel = (ModelName . pack) <$> (((char '(') *> parseModelInner <* (char ')')) <|> parseModelInner)+ parser = do+ path <- parseModel `sepBy1` char '.'+ model <- optional $ do+ char '='+ mo <- parseModel+ return mo+ return (path, model)+ result = parse ((Dhall.Parser.unParser parser `sepBy1` char ',') <* eof) "MAPPING"+++parseOptions :: Options.Applicative.Parser Options+parseOptions = Options <$> parseSkip <*> 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"+ )+ parsePrefixMap' =+ option Data.Map.empty $ Options.Applicative.option parsePrefixMap+ ( Options.Applicative.long "prefixMap"+ <> 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. Also note that top level model names in a path must use () when the name contains '.'"+ <> Options.Applicative.metavar "SPLITS"+ )+ fileArg = Options.Applicative.strArgument+ ( Options.Applicative.help "The input file to read"+ <> Options.Applicative.metavar "FILE"+ <> Options.Applicative.action "file"+ )+ crdArg = Options.Applicative.switch+ ( Options.Applicative.long "crd"+ <> Options.Applicative.help "The input file is a custom resource definition"+ )++-- | `ParserInfo` for the `Options` type+parserInfoOptions :: Options.Applicative.ParserInfo Options+parserInfoOptions =+ Options.Applicative.info+ (Options.Applicative.helper <*> parseOptions)+ ( Options.Applicative.progDesc "Swagger to Dhall generator"+ <> Options.Applicative.fullDesc+ )++main :: IO ()+main = do+ GHC.IO.Encoding.setLocaleEncoding System.IO.utf8++ Options{..} <- Options.Applicative.execParser parserInfoOptions++ let duplicateHandler =+ if skipDuplicates+ then skipDuplicatesHandler+ else preferStableResource++ -- Get the Definitions+ defs <-+ if crd then do+ crdFile <- eitherDecodeFileStrict filename+ case crdFile of+ Left e -> do+ fail $ "Unable to decode the CRD file. " <> show e+ Right s -> do+ case Convert.toDefinition s of+ Left text -> do+ fail (Text.unpack text)+ Right result -> do+ return (Data.Map.fromList [result])+ else do+ swaggerFile <- decodeFileStrict filename+ case swaggerFile of+ Nothing -> fail "Unable to decode the Swagger file"+ Just (Swagger{..}) -> pure definitions++ let fix m = Data.Map.adjust patchCyclicImports (ModelName m)++ -- Convert to Dhall types in a Map+ 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"+ defs++ -- Output to types+ Directory.createDirectoryIfMissing True "types"+ for_ (Data.Map.toList types) $ \(ModelName name, expr) -> do+ let path = "./types" </> unpack name <> ".dhall"+ writeDhall path expr++ -- Convert from Dhall types to defaults+ let defaults = Data.Map.mapMaybeWithKey (Convert.toDefault prefixMap defs) types++ -- Output to defaults+ Directory.createDirectoryIfMissing True "defaults"+ for_ (Data.Map.toList defaults) $ \(ModelName name, expr) -> do+ let path = "./defaults" </> unpack name <> ".dhall"+ writeDhall path expr++ let mkEmbedField = Dhall.makeRecordField . Dhall.Embed++ let toSchema (ModelName key) _ _ =+ Dhall.RecordLit+ [ ("Type", mkEmbedField (Convert.mkImport prefixMap ["types", ".."] (key <> ".dhall")))+ , ("default", mkEmbedField (Convert.mkImport prefixMap ["defaults", ".."] (key <> ".dhall")))+ ]++ let schemas = Data.Map.intersectionWithKey toSchema types defaults++ let package =+ Combine+ mempty+ Nothing+ (Embed (Convert.mkImport prefixMap [ ] "schemas.dhall"))+ (RecordLit+ [ ( "IntOrString"+ , Dhall.makeRecordField $ Field (Embed (Convert.mkImport prefixMap [ ] "types.dhall")) $ Dhall.makeFieldSelection "IntOrString"+ )+ , ( "Resource", mkEmbedField (Convert.mkImport prefixMap [ ] "typesUnion.dhall"))+ ]+ )++ -- Output schemas that combine both the types and defaults+ Directory.createDirectoryIfMissing True "schemas"+ for_ (Data.Map.toList schemas) $ \(ModelName name, expr) -> do+ let path = "./schemas" </> unpack name <> ".dhall"+ writeDhall path expr++ -- Output the types record, the defaults record, and the giant union type+ let getImportsMap = Convert.getImportsMap prefixMap duplicateHandler objectNames+ makeRecordMap = Dhall.Map.mapMaybe (Just . Dhall.makeRecordField)+ objectNames = Data.Map.keys types+ typesMap = getImportsMap "types" $ Data.Map.keys types+ defaultsMap = getImportsMap "defaults" $ Data.Map.keys defaults+ schemasMap = getImportsMap "schemas" $ Data.Map.keys schemas++ typesRecordPath = "./types.dhall"+ typesUnionPath = "./typesUnion.dhall"+ defaultsRecordPath = "./defaults.dhall"+ schemasRecordPath = "./schemas.dhall"+ packageRecordPath = "./package.dhall"++ writeDhall typesUnionPath (Dhall.Union $ fmap Just typesMap)+ writeDhall typesRecordPath (Dhall.RecordLit $ makeRecordMap typesMap)+ writeDhall defaultsRecordPath (Dhall.RecordLit $ makeRecordMap defaultsMap)+ writeDhall schemasRecordPath (Dhall.RecordLit $ makeRecordMap schemasMap)+ writeDhall packageRecordPath package
+ src/Dhall/Kubernetes/Convert.hs view
@@ -0,0 +1,537 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}++module Dhall.Kubernetes.Convert+ ( toTypes+ , toDefault+ , 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.Scientific (Scientific)+import Data.Set (Set)+import Data.Text (Text)+import Dhall.Kubernetes.Types+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)++-- | 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 :: ModelHierarchy -> Maybe (Set FieldName) -> Set FieldName+requiredFields modelHierarchy required+ = Set.difference+ (List.foldr Set.union (fromMaybe Set.empty required) [alwaysRequired, toAdd])+ toRemove+ where+ alwaysRequired = Set.fromList $ FieldName <$> [ "apiVersion", "kind", "metadata"]+ toAdd = fromMaybe Set.empty $ Data.Map.lookup modelHierarchy requiredConstraints+ toRemove = fromMaybe Set.empty $ Data.Map.lookup modelHierarchy notRequiredConstraints++ -- | Some models require keys that are not in the required set,+ -- but are in the docs or just work+ requiredConstraints = Data.Map.fromList [ ]++ -- | 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"]+ , Set.fromList [ FieldName "apiVersion" ]+ )+ , ( [ModelName "io.k8s.apimachinery.pkg.apis.meta.v1.StatusDetails"]+ , Set.fromList [ FieldName "kind" ]+ )+ , ( [ModelName "io.k8s.api.core.v1.PersistentVolumeClaim"]+ , Set.fromList [ FieldName "apiVersion", FieldName "kind" ]+ )+ , ( [ModelName "io.k8s.api.batch.v1beta1.JobTemplateSpec"]+ , Set.fromList [ FieldName "metadata" ]+ )+ , ( [ModelName "io.k8s.api.batch.v2alpha1.JobTemplateSpec"]+ , Set.fromList [ FieldName "metadata" ]+ )+ , ( [ModelName "io.k8s.api.core.v1.PodTemplateSpec"]+ , Set.fromList [ FieldName "metadata" ]+ )+ ]+++-- | Get a filename from a Swagger ref+pathFromRef :: Ref -> Text+pathFromRef (Ref r) = (Text.split (== '/') r) List.!! 2++-- | Build an import from path components (note: they need to be in reverse order)+-- and a filename+mkImport :: Data.Map.Map Prefix Dhall.Import -> [Text] -> Text -> Dhall.Import+mkImport prefixMap components file =+ case Data.Map.toList filteredPrefixMap of+ [] -> localImport+ xs -> (snd . head $ Sort.sortOn (Text.length . fst) xs) <> localImport+ where+ localImport = Dhall.Import{..}+ importMode = Dhall.Code+ importHashed = Dhall.ImportHashed{..}+ hash = Nothing+ importType = Dhall.Local Dhall.Here Dhall.File{..}+ directory = Dhall.Directory{..}+ filteredPrefixMap = Data.Map.filterWithKey (\k _ -> Text.isPrefixOf k file) prefixMap++-- | Get the namespaced object name if the Import points to it+namespacedObjectFromImport :: Dhall.Import -> Maybe Text+namespacedObjectFromImport Dhall.Import+ { importHashed = Dhall.ImportHashed+ { importType = Dhall.Local Dhall.Here Dhall.File+ { file = f , .. }+ , .. }+ , .. } = Just $ Text.replace ".dhall" "" f+namespacedObjectFromImport _ = Nothing++-- | Get a Dhall Text literal from a lone string+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) => (a -> a -> Bool) -> Data.Map.Map k a -> Data.Map.Map k a -> Data.Map.Map k a+mergeNoConflicts canMerge = Data.Map.unionWithKey+ (\key left right ->+ if canMerge 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 ModelHierarchy (Maybe ModelName) -> ModelHierarchy -> Definition -> Maybe ModelName+pathSplitter pathsAndModels modelHierarchy definition+ | (Maybe.isJust $ properties definition) && Maybe.isJust model = model+ | otherwise = Nothing+ where+ model = case Data.Map.lookup modelHierarchy 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 -> ([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++ -- some CRDs are equal all except for the top description. This is safe as the only usage of description+ -- is 'guessModelNameForSplit' which has already been called for the top definition+ equalsIgnoringDescription :: Definition -> Definition -> Bool+ equalsIgnoringDescription a b = a { description = description b } == b++ 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++ (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.Integer), ("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+ | 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+ 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)+ "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+ :: Data.Map.Map Prefix Dhall.Import -- ^ Mapping of prefixes to import roots+ -> Data.Map.Map ModelName Definition -- ^ All the Swagger definitions+ -> ModelName -- ^ The name of the object we're converting+ -> Expr -- ^ The Dhall type of the object+ -> Maybe Expr+toDefault prefixMap definitions modelName = go+ where+ go = \case+ -- If we have an import, we also import in the default+ e@(Dhall.Embed _) -> Just e+ -- For a sum type, there is no obvious default value+ Dhall.Union _ -> Nothing+ -- Dynamic records (i.e. List { mapKey : Text, mapValue : Text }) also+ -- don't have default+ Dhall.App Dhall.List _ -> Nothing+ -- Simple types should not have a default+ Dhall.Text -> Nothing+ Dhall.Natural -> Nothing+ -- But most of the times we are dealing with a record.+ -- Here we transform the record type in a value, transforming the keys in+ -- this way:+ --+ -- * take the BaseData from definition and populate it+ -- * skip other required fields, except if they are records+ -- * set the optional fields to None and the lists to empty+ Dhall.Record kvsf ->+ let getBaseData :: Maybe Definition -> Dhall.Map.Map Text Expr+ getBaseData (Just Definition{ baseData = Just BaseData{..} }) =+ Dhall.Map.fromList+ [ ("apiVersion", toTextLit apiVersion)+ , ("kind" , toTextLit kind )+ ]+ getBaseData _ = mempty++ baseData = getBaseData $ Data.Map.lookup modelName definitions++ -- | Given a Dhall type from a record field, figure out if and what+ -- default value it should have+ valueForField :: Expr -> Maybe Expr+ valueForField = \case+ Dhall.App Dhall.Optional _T -> do+ let expression = Dhall.App Dhall.None _T++ let adjustedExpression =+ Dhall.Optics.transformOf+ Dhall.subExpressions+ adjustImport+ expression++ return adjustedExpression+ _ -> do+ empty++ kvs = Dhall.Map.mapMaybe (Just . Dhall.recordFieldValue) kvsf++ adaptRecordMap = Dhall.Map.mapMaybe (Just . Dhall.makeRecordField)++ -- The main reason for adding this special case is so that the+ -- `apiVersion` and `kind` fields default to `Some …` instead of+ -- `None …`.+ combine l (Dhall.App Dhall.None _T) = Dhall.Some l+ combine _ r = r++ in Just $ Dhall.RecordLit $ adaptRecordMap $ Dhall.Map.unionWith combine baseData (Dhall.Map.mapMaybe valueForField kvs)++ -- We error out here because wildcards are bad, and we should know if+ -- we get something unexpected+ e -> error $ show modelName <> "\n\n" <> show e++ -- | The imports that we get from the types are referring to the local folder,+ -- but if we want to refer them from the defaults we need to adjust the path+ adjustImport :: Expr -> Expr+ adjustImport (Dhall.Embed imp) | Just file <- namespacedObjectFromImport imp+ = Dhall.Embed $ mkImport prefixMap ["types", ".."] (file <> ".dhall")+ adjustImport other = other+++-- | Get a Dhall.Map filled with imports, for creating giant Records or Unions of types or defaults+getImportsMap+ :: Data.Map.Map Prefix Dhall.Import -- ^ Mapping of prefixes to import roots+ -> DuplicateHandler -- ^ Duplicate name handler+ -> [ModelName] -- ^ A list of all the object names+ -> Text -- ^ The folder we should get imports from+ -> [ModelName] -- ^ List of the object names we want to include in the Map+ -> Dhall.Map.Map Text Expr+getImportsMap prefixMap duplicateNameHandler objectNames folder toInclude+ = Dhall.Map.fromList+ $ Data.Map.elems+ -- This intersection is here to "pick" common elements between "all the objects"+ -- and "objects we want to include", already associating keys to their import+ $ Data.Map.intersectionWithKey+ (\(ModelName name) key _ -> (key, Dhall.Embed $ mkImport prefixMap [folder] (name <> ".dhall")))+ namespacedToSimple+ (Data.Map.fromList $ fmap (,()) toInclude)+ where+ -- | A map from namespaced names to simple ones (i.e. without the namespace)+ namespacedToSimple+ = Data.Map.fromList $ mapMaybe selectObject $ Data.Map.toList $ groupByObjectName objectNames++ -- | Given a list of fully namespaced objects, it will group them by the+ -- object name+ groupByObjectName :: [ModelName] -> Data.Map.Map Text [ModelName]+ groupByObjectName modelNames = Data.Map.unionsWith (<>)+ $ (\name -> Data.Map.singleton (getKind name) [name])+ <$> modelNames+ where+ getKind (ModelName name) =+ let elems = Text.split (== '.') name+ in elems List.!! (length elems - 1)++ -- | There will be more than one namespaced object for a single object name+ -- (because different API versions, and objects move around packages but k8s+ -- cannot break compatibility so we have all of them), so we have to select one+ -- (and we error out if it's not so after the filtering)+ selectObject :: (Text, [ModelName]) -> Maybe (ModelName, Text)+ selectObject (kind, namespacedNames) = fmap (,kind) namespaced+ where+ filterFn (ModelName name) = not $ or+ -- The reason why we filter these two prefixes is that they are "internal"+ -- objects. I.e. they do not appear referenced in other objects, but are+ -- just in the Go source. E.g. see https://godoc.org/k8s.io/kubernetes/pkg/apis/core+ [ Text.isPrefixOf "io.k8s.kubernetes.pkg.api." name+ , Text.isPrefixOf "io.k8s.kubernetes.pkg.apis." name+ -- We keep a list of "old" objects that should not be preferred/picked+ ]++ namespaced = case filter filterFn namespacedNames of+ [name] -> Just name+ [] -> Nothing+ names -> duplicateNameHandler (kind, names)++stripPrefix :: (Generic a, GFromJSON Zero (Rep a)) => Int -> Value -> Parser a+stripPrefix n = genericParseJSON options+ where+ options = defaultOptions { fieldLabelModifier }++ removePrefix string = case drop n string of+ s : tring -> Char.toLower s : tring+ [] -> []+ extensionRename string = case string of+ "IntOrString" -> "x-kubernetes-int-or-string"+ a -> a++ fieldLabelModifier = removePrefix . extensionRename++data V1CustomResourceDefinition =+ V1CustomResourceDefinition+ { v1CustomResourceDefinitionSpec :: V1CustomResourceDefinitionSpec+ }+ deriving (Generic)+++instance FromJSON V1CustomResourceDefinition where+ parseJSON = stripPrefix 26++data V1CustomResourceDefinitionSpec =+ V1CustomResourceDefinitionSpec+ { v1CustomResourceDefinitionSpecGroup :: Text+ , v1CustomResourceDefinitionSpecNames :: V1CustomResourceDefinitionNames+ , v1CustomResourceDefinitionSpecVersions :: Maybe [V1CustomResourceDefinitionVersion]+ } deriving (Generic)++instance FromJSON V1CustomResourceDefinitionSpec where+ parseJSON = stripPrefix 30++data V1CustomResourceDefinitionNames =+ V1CustomResourceDefinitionNames+ { v1CustomResourceDefinitionNamesKind :: Text+ } deriving (Generic)++instance FromJSON V1CustomResourceDefinitionNames where+ parseJSON = stripPrefix 31++data V1CustomResourceValidation =+ V1CustomResourceValidation+ { v1CustomResourceValidationOpenAPIV3Schema :: Maybe V1JSONSchemaProps+ } deriving (Generic)++instance FromJSON V1CustomResourceValidation where+ parseJSON = stripPrefix 26++data V1CustomResourceDefinitionVersion =+ V1CustomResourceDefinitionVersion+ { v1CustomResourceDefinitionVersionName :: Text+ , v1CustomResourceDefinitionVersionSchema :: Maybe V1CustomResourceValidation+ } deriving (Generic)++instance FromJSON V1CustomResourceDefinitionVersion where+ parseJSON = stripPrefix 33++data V1JSONSchemaProps =+ V1JSONSchemaProps+ { v1JSONSchemaPropsRef :: Maybe Text+ , v1JSONSchemaPropsDescription :: Maybe Text+ , v1JSONSchemaPropsFormat :: Maybe Text+ , v1JSONSchemaPropsMinimum :: Maybe Scientific+ , v1JSONSchemaPropsExclusiveMinimum :: Maybe Bool+ , v1JSONSchemaPropsItems :: Maybe Value+ , v1JSONSchemaPropsProperties :: Maybe (Data.Map.Map String V1JSONSchemaProps)+ , v1JSONSchemaPropsRequired :: Maybe [Text]+ , v1JSONSchemaPropsType :: Maybe Text+ , v1JSONSchemaPropsIntOrString :: Maybe Bool+ } deriving (Generic)++instance FromJSON V1JSONSchemaProps where+ parseJSON = stripPrefix 17++mkV1JSONSchemaProps :: V1JSONSchemaProps+mkV1JSONSchemaProps =+ V1JSONSchemaProps+ { v1JSONSchemaPropsRef = Nothing+ , v1JSONSchemaPropsDescription = Nothing+ , v1JSONSchemaPropsFormat = Nothing+ , v1JSONSchemaPropsMinimum = Nothing+ , v1JSONSchemaPropsExclusiveMinimum = Nothing+ , v1JSONSchemaPropsItems = Nothing+ , v1JSONSchemaPropsProperties = Nothing+ , v1JSONSchemaPropsRequired = Nothing+ , v1JSONSchemaPropsType = Nothing+ , v1JSONSchemaPropsIntOrString = Nothing+ }++orDie :: Maybe a -> e -> Either e a+Just r `orDie` _ = Right r+Nothing `orDie` l = Left l++toDefinition+ :: V1CustomResourceDefinition -> Either Text (ModelName, Definition)+toDefinition crd = fmap (\d -> (modelName, d)) definition+ where+ V1CustomResourceDefinition{..} = crd++ V1CustomResourceDefinitionSpec{..} = v1CustomResourceDefinitionSpec++ V1CustomResourceDefinitionNames{..} = v1CustomResourceDefinitionSpecNames++ modelName =+ ModelName (v1CustomResourceDefinitionSpecGroup <> "." <> v1CustomResourceDefinitionNamesKind)++ definition = do+ versions <- v1CustomResourceDefinitionSpecVersions+ `orDie` "The CustomResourceDefinitionSpec is missing the versions field"++ V1CustomResourceDefinitionVersion{..} <- case versions of+ [ version ] ->+ return version+ _ ->+ Left "This tool does not yet support more than one version for the versions field of the CustomResourceDefinitionSpec"++ V1CustomResourceValidation{..} <- v1CustomResourceDefinitionVersionSchema+ `orDie` "The CustomResourceDefinitionSpec is missing the schema field"++ openApiv3Schema <- v1CustomResourceValidationOpenAPIV3Schema+ `orDie` "The CustomResourceValidation is missing the openApiv3Schema field"++ let baseData = BaseData {+ kind = v1CustomResourceDefinitionNamesKind,++ apiVersion = v1CustomResourceDefinitionVersionName+ }++ let completeSchemaProperties =+ fmap+ (Data.Map.union+ (+ Data.Map.fromList [+ ("apiVersion", (mkV1JSONSchemaProps {v1JSONSchemaPropsType = Just "string"}))+ , ("kind", (mkV1JSONSchemaProps {v1JSONSchemaPropsType = Just "string"} ))+ , ("metadata", mkV1JSONSchemaProps {v1JSONSchemaPropsType = Just "object", v1JSONSchemaPropsRef = Just "#/definitions/io.k8s.apimachinery.pkg.apis.meta.v1.ObjectMeta"} )+ ]+ ))+ (v1JSONSchemaPropsProperties openApiv3Schema)++ let completeSchema = openApiv3Schema { v1JSONSchemaPropsProperties = completeSchemaProperties}++ pure $ propsToDefinition completeSchema (Just baseData)++ 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+ }++ toProperties :: Data.Map.Map String V1JSONSchemaProps -> Data.Map.Map ModelName Definition+ toProperties props =+ (Data.Map.fromList . fmap (\(k, p) -> ((ModelName . Text.pack) k, propsToDefinition p Nothing)) . Data.Map.toList) props
+ src/Dhall/Kubernetes/Data.hs view
@@ -0,0 +1,25 @@+module Dhall.Kubernetes.Data where++import Dhall.Kubernetes.Types++import qualified Data.Map.Strict as Data.Map+import qualified Data.Set as Set+++-- | This just removes the offending keys from the definition+patchCyclicImports :: Definition -> Definition+patchCyclicImports Definition{ properties = oldProps, .. } = Definition{..}+ where+ properties = fmap (\propsMap -> Data.Map.withoutKeys propsMap toRemove) oldProps+ toRemove =+ Set.fromList $+ ( ModelName+ <$> [ "allOf"+ , "anyOf"+ , "not"+ , "oneOf"+ , "additionalItems"+ , "additionalProperties"+ , "items"+ ]+ )
+ src/Dhall/Kubernetes/Types.hs view
@@ -0,0 +1,108 @@+module Dhall.Kubernetes.Types where++import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Dhall.Core as Dhall+import qualified Dhall.Parser as Dhall++import Control.Applicative (optional)+import Control.Monad (join)+import Data.Aeson+import Data.Map (Map)+import Data.Scientific (Scientific)+import Data.Set (Set)+import Data.Text (Text)+import Data.Text.Prettyprint.Doc (Pretty)+import GHC.Generics (Generic)+++type Expr = Dhall.Expr Dhall.Src Dhall.Import++type DuplicateHandler = (Text, [ModelName]) -> Maybe ModelName++type Prefix = Text++type ModelHierarchy = [ModelName]++{-| Type for the Swagger specification.++There is such a type defined in the `swagger2` package, but Kubernetes' OpenAPI+file doesn't conform to that, so here we implement a small version of that+tailored to our needs.++-}+data Swagger = Swagger+ { definitions :: Map ModelName Definition+ } deriving (Generic, Show)++instance FromJSON Swagger+++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+ } 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"+ pure Definition{..}+++newtype Ref = Ref { unRef :: Text }+ 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)+++{-| This contains the static data that a Model might have++This applies only to kubernetes resources where ``kind`` and+``apiVersion`` are statically determined by the resource. See the+`Kubernetes OpenAPI Spec Readme`:+https://github.com/kubernetes/kubernetes/blob/master/api/openapi-spec/README.md#x-kubernetes-group-version-kind++For example for a v1 Deployment we have++{ kind = "Deployment"+, apiVersion = "apps/v1"+}++-}+data BaseData = BaseData+ { kind :: Text+ , apiVersion :: Text+ } deriving (Generic, Show, Eq)++instance FromJSON BaseData where+ parseJSON = withArray "array of values" $ \arr -> withObject "baseData" (\o -> do+ group <- o .:? "group" .!= ""+ kind <- o .: "kind"+ version <- o .: "version"+ let apiVersion = (if Text.null group then "" else group <> "/") <> version+ pure BaseData{..})+ (head $ Vector.toList arr)