diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dhall-openapi.cabal b/dhall-openapi.cabal new file mode 100644 --- /dev/null +++ b/dhall-openapi.cabal @@ -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 diff --git a/openapi-to-dhall/Main.hs b/openapi-to-dhall/Main.hs new file mode 100644 --- /dev/null +++ b/openapi-to-dhall/Main.hs @@ -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 diff --git a/src/Dhall/Kubernetes/Convert.hs b/src/Dhall/Kubernetes/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Kubernetes/Convert.hs @@ -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 diff --git a/src/Dhall/Kubernetes/Data.hs b/src/Dhall/Kubernetes/Data.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Kubernetes/Data.hs @@ -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" + ] + ) diff --git a/src/Dhall/Kubernetes/Types.hs b/src/Dhall/Kubernetes/Types.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Kubernetes/Types.hs @@ -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)