diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,18 +1,42 @@ # Changelog for baserock-schema -## 0.0.2.0 (PreAlpha) +## 0.0.3.4 +Use hackage version of gitlab-api + +## 0.0.3.3 + +Fix build-mode typo + +## 0.0.3.2 + +Upgrade set-all-refs and bump-shas to work on system or stratum dynamically + +## 0.0.3.1 + +Catch errors when sha is not found when updating. +Drop .git suffix when attempting to contact gitlab api + +## 0.0.3.0 + +Switch to use Haskell-etc for cli options +Get basic lens functionality working +Drop MonadState database, it's not needed +Depend on yaml-pretty-extras or file lensing + +## 0.0.2.0 + Switch to use RIO for main loading systems Add basic MonadState database for Definitions Example sanitizer -## 0.0.1.5 (PreAlpha) +## 0.0.1.5 * Fix some schema issues. * Add lens interfaces. * Add example application using gitlab-api -## 0.0.1.0 (PreAlpha) +## 0.0.1.0 * Add Basic Chunk, Stratum and System parsing for baserock definitions V9 * Add "AST" decoders/encoders diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,10 +10,18 @@ stack test -You can test the in-place sanitizer application by running +You can test the in-place application by running stack install which will install the baserock executable. You may then sit in a definitions repository and run baserock sanitize + +You can set all the refs in a given stratum by runnings + + baserock set-all-refs + +For gitlab-only strata you can bump the shas to the latest head of that ref by doing + + baserock bump-shas diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,76 +1,179 @@ -{-# LANGUAGE QuasiQuotes #-} +module Main where +import qualified Prelude + +import RIO hiding (view) +import RIO.List.Partial +import qualified RIO.HashMap as HM +import qualified RIO.HashMap.Partial as HMP +import RIO.Process +import qualified RIO.Text as Text +import qualified RIO.Text.Partial as TextP + import Baserock.Schema.V9 -import Control.Monad.State +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as JSON +import qualified Data.Aeson.Types as JSON (typeMismatch) +import Data.Hashable (Hashable) import Gitlab +import GHC.Generics (Generic) import Lens.Micro.Platform -import RIO -import RIO.List.Partial -import qualified RIO.ByteString as BS -import qualified RIO.HashMap as HM -import qualified RIO.HashMap.Partial as HMP -import qualified RIO.Text as Text -import qualified RIO.Text.Partial as TextP -import System.Environment ( getEnv - , getArgs - ) -import System.Console.Docopt +import qualified System.Etc as Etc -patterns :: Docopt -patterns = [docopt| -Usage: - baserock bump-shas - baserock sanitize -|] +import Paths_baserock_schema (getDataFileName) -getArgOrExit = getArgOrExitWith patterns +-------------------------------------------------------------------------------- +-- We specify the support commands for our program -chunkLatest :: MonadGitlab m => Chunk -> m GitlabCommitData -chunkLatest = liftM2 getShaOfRef (toSignificantSuffix . _repo) _ref +data Cmd + = PrintConfig + | Sanitize + | SetAllRefs + | BumpShas + deriving (Show, Eq, Generic) -bumpChunkSha :: MonadGitlab m => Chunk -> m Chunk -bumpChunkSha c = fmap (flip (sha ?~) c . commitId) . chunkLatest $ c +instance Hashable Cmd +instance JSON.FromJSON Cmd where + parseJSON json = + case json of + JSON.String cmdName + | cmdName == "config" -> return PrintConfig + | cmdName == "sanitize" -> return Sanitize + | cmdName == "set-all-refs" -> return SetAllRefs + | cmdName == "bump-shas" -> return BumpShas + | otherwise -> JSON.typeMismatch ("Cmd (" <> Text.unpack cmdName <> ")") json + _ -> JSON.typeMismatch "Cmd" json + +instance JSON.ToJSON Cmd where + toJSON cmd = + case cmd of + PrintConfig -> JSON.String "config" + Sanitize -> JSON.String "sanitize" + SetAllRefs -> JSON.String "set-all-refs" + BumpShas -> JSON.String "bump-shas" + +--------------------------------------------------------------------------------- + +type Aliases = HashMap Text Text + +chunkLatest :: MonadGitlab env m => Chunk -> m (Maybe GitlabCommitData) +chunkLatest c = forM (liftA2 (,) (Text.dropSuffix ".git" . toSignificantSuffix <$> _repo c) (_ref c)) $ uncurry getCommitData + +expandAliases :: Aliases -> Chunk -> Chunk +expandAliases as = over (repo . _Just) (flip (HM.foldrWithKey TextP.replace) as) + +bumpChunkSha :: (MonadGitlab env m, HasLogFunc env, MonadUnliftIO m) => Aliases -> Chunk -> m Chunk +bumpChunkSha as c = if isNothing $ _repo c then return c else do + logInfo $ "Grabbing latest sha for project " <> display (view (repo . _Just) c) <> " on branch " <> display (view (ref . _Just) c) + t <- catch (chunkLatest $ expandAliases as c) $ \(e :: SomeException) -> do + logInfo "No value found, moving on." + return Nothing + case t of + Just x -> do + logInfo $ "Got value: " <> display (_glCommitId x) + return $ (sha ?~ _glCommitId x) c + Nothing -> return c + +toSignificantSuffix = (!! 1) . TextP.splitOn ":" + getAliases ybdconf = do - ybdconf <- decodeFile ybdconf :: IO (Maybe Object) - let Just (Object as) = parseMaybe (.: "aliases") =<< ybdconf :: Maybe Value + ybdconf <- decodeFileThrow ybdconf + let Right (Object as) = parseEither (.: "aliases") ybdconf return $ (\(String y) -> y) <$> as -toSignificantSuffix = (!! 1) . TextP.splitOn ":" +sanitizeStratum :: (MonadIO m, MonadThrow m) => FilePath -> m Stratum +sanitizeStratum = sanitizeFile -sanitize x = do - s <- loadSystem x - xs <- use defStrata - logInfo $ "Saving all strata in system " <> displayShow x - forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $ - liftM2 encodeFilePrettyLogged (Text.unpack) (xs HMP.!) - encodeFilePrettyLogged x s +setStratumRef :: (MonadReader env m, HasLogFunc env, MonadIO m, MonadThrow m) => FilePath -> Text -> m Stratum +setStratumRef f a = do + logInfo $ "Setting ref of Stratum " <> displayShow f <> " to " <> displayShow a + inplace overFile f (chunks . traverse) (ref ?~ a) +setSystemRef :: (MonadReader env m, HasLogFunc env, MonadIO m, MonadThrow m) => FilePath -> Text -> m System +setSystemRef f a = do + logInfo $ "Setting ref of System " <> displayShow f <> " to " <> displayShow a + s <- decodeFileThrow f + forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $ flip setStratumRef a . Text.unpack + return s + +bumpStratum as f = do + logInfo $ "Bumping all shas in stratum " <> displayShow f + inplace traverseOfFile f (chunks . traverse) (bumpChunkSha as) + +bumpSystem as f = do + logInfo $ "Bumping all shas in system " <> displayShow f + s <- decodeFileThrow f + forM_ (s ^.. (strata. traverse . stratumIncludeMorph)) $ bumpStratum as . Text.unpack + return s + +data BaserockApp = + BaserockApp { + appLogFunc :: !LogFunc + , appProcessContext :: !ProcessContext + , appGitlabConfig :: !GitlabConfig + } + +instance HasLogFunc BaserockApp where + logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y }) + +instance HasProcessContext BaserockApp where + processContextL = lens appProcessContext (\x y -> x { appProcessContext = y }) + +instance HasGitlabConfig BaserockApp where + gitlabConfigL = lens appGitlabConfig (\x y -> x { appGitlabConfig = y }) + +main :: IO () main = do - args <- parseArgsOrExit patterns =<< getArgs + specPath <- getDataFileName "spec.yaml" + configSpec <- Etc.readConfigSpec (Text.pack specPath) + Etc.reportEnvMisspellingWarnings configSpec + + (configFiles, _fileWarnings) <- Etc.resolveFiles configSpec + (cmd , configCli ) <- Etc.resolveCommandCli configSpec + configEnv <- Etc.resolveEnv configSpec + + let configDefault = Etc.resolveDefault configSpec + + config = configDefault `mappend` configFiles `mappend` configEnv `mappend` configCli + logOptions <- logOptionsHandle stdout True - when (args `isPresent` command "sanitize") $ do - f <- args `getArgOrExit` argument "system" - withLogFunc logOptions $ flip runRIO $ - void $ flip execStateT mempty $ sanitize f + let cValueS = flip Etc.getConfigValue config :: [Text] -> IO String + let cValueB = flip Etc.getConfigValue config :: [Text] -> IO Bool - when (args `isPresent` command "bump-shas") $ do - f <- args `getArgOrExit` argument "stratum" - envPrivateToken <- getEnv "GITLAB_PRIVATE_TOKEN" - envBaseUrl <- getEnv "GITLAB_BASE_URL" + appProcessContext <- mkDefaultProcessContext - aliases <- getAliases "ybd.conf" + withLogFunc logOptions $ \logFunc -> case cmd of + PrintConfig -> Etc.printPrettyConfig config - let gconf = GitlabConfig - { glCredsUrl = fromString envBaseUrl - , glCredsToken = fromString envPrivateToken - } + Sanitize -> do + f <- cValueS ["system"] + runRIO logFunc $ do + logInfo $ "Sanitizing system " <> displayShow f + s <- sanitizeFile f + forM_ (s ^.. (strata . traverse . stratumIncludeMorph)) $ \x -> do + logInfo $ "Sanitizing stratum " <> displayShow x + sanitizeStratum . Text.unpack $ x - withLogFunc logOptions $ flip runRIO $ do - s <- decodeFileThrowLogged f - let s2 = expandAliases aliases s - r <- runGitlab gconf $ traverseOf (chunks . traverse) bumpChunkSha s2 - let s3 = contractAliases aliases r - encodeFilePrettyLogged f s3 + SetAllRefs -> do + f <- cValueS ["morph"] + a <- cValueS ["ref"] + runRIO logFunc $ void $ do + (m :: Value) <- decodeFileThrow f + case m ^? JSON.key "kind" of + Just (String "stratum") -> void $ setStratumRef f (Text.pack a) + Just (String "system") -> void $ setSystemRef f (Text.pack a) + + BumpShas -> do + f <- cValueS ["morph"] + gUrl <- cValueS ["gitlab", "url"] + gToken <- cValueS ["gitlab", "token"] + aliases <- liftIO $ getAliases "ybd.conf" + let gConfg = GitlabConfig (fromString gUrl) (fromString gToken) + runRIO (BaserockApp logFunc appProcessContext gConfg) $ do + (m :: Value) <- decodeFileThrow f + case m ^? JSON.key "kind" of + Just (String "stratum") -> void $ bumpStratum aliases f + Just (String "system") -> void $ bumpSystem aliases f diff --git a/baserock-schema.cabal b/baserock-schema.cabal --- a/baserock-schema.cabal +++ b/baserock-schema.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 92f2b3a2df36fec782d09691a9d06d723cb278e0aec4142eb412bd9fde8753b7 +-- hash: a5b52313d9210e678dfe4723abea61a8ef2dc52296cc1f6a7c0fb18ccef4e211 name: baserock-schema -version: 0.0.2.0 +version: 0.0.3.4 synopsis: Baserock Definitions Schema description: Baserock Definitions Schema - Parsers, Printers, Encoders, Decoders, ASTs, Graphs and Traversals category: Data @@ -19,6 +19,9 @@ extra-source-files: ChangeLog.md README.md +data-files: + spec.yaml +data-dir: resources source-repository head type: git @@ -28,22 +31,16 @@ exposed-modules: Baserock Baserock.Schema.V9 - Baserock.Schema.V9.Data - Baserock.Schema.V9.Database other-modules: Paths_baserock_schema hs-source-dirs: src default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns build-depends: - algebraic-graphs + aeson , base >=4.7 && <5 - , errors - , flippers , microlens-platform - , mtl , rio - , yaml , yaml-pretty-extras default-language: Haskell2010 @@ -56,17 +53,15 @@ default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - algebraic-graphs + aeson , base >=4.7 && <5 , baserock-schema - , docopt - , errors - , flippers + , etc , gitlab-api + , hashable + , lens-aeson , microlens-platform - , mtl , rio - , yaml , yaml-pretty-extras default-language: Haskell2010 @@ -81,16 +76,11 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck - , algebraic-graphs + , aeson , base >=4.7 && <5 , baserock-schema - , bytestring - , errors - , flippers , hspec , microlens-platform - , mtl , rio - , yaml , yaml-pretty-extras default-language: Haskell2010 diff --git a/resources/spec.yaml b/resources/spec.yaml new file mode 100644 --- /dev/null +++ b/resources/spec.yaml @@ -0,0 +1,66 @@ +etc/files: + env: YBD_CONF + paths: + - "ybd.conf" + +etc/cli: + desc: "baserock - Utility toolkit for manipulating definitions" + header: "baserock - Utility toolkit for manipulating definitions" + commands: + config: + desc: "Prints configuration summary" + header: "Prints configuration summary" + sanitize: + desc: "Sanitizes an entire system down to the level of strata" + header: "" + set-all-refs: + desc: "Set all refs in a stratum to a particular value" + header: "" + bump-shas: + desc: "Bump all shas in a stratum" + header: "" + +etc/entries: + morph: + etc/spec: + type: "string" + help: "Morphology filepath" + cli: + input: "argument" + metavar: "MORPHFILE" + commands: + - set-all-refs + - bump-shas + ref: + etc/spec: + type: "string" + help: "Value to set" + cli: + input: "argument" + metavar: "REF" + commands: + - set-all-refs + gitlab: + url: + etc/spec: + type: "string" + help: "Gitlab url" + env: "GITLAB_BASE_URL" + cli: + input: "option" + short: "u" + metavar: "GITLAB_BASE_URL" + commands: + - bump-shas + token: + etc/spec: + sensitive: true + type: "string" + env: "GITLAB_API_TOKEN" + help: "Gitlab private token" + cli: + input: "option" + short: "t" + metavar: "GITLAB_API_TOKEN" + commands: + - bump-shas diff --git a/src/Baserock/Schema/V9.hs b/src/Baserock/Schema/V9.hs --- a/src/Baserock/Schema/V9.hs +++ b/src/Baserock/Schema/V9.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | --- Module : Baserock.Schema.V9 +-- Module : Baserock.Schema.V9.Data -- Copyright : (c) Daniel Firth 2018 -- License : BSD3 -- Maintainer : locallycompact@gmail.com @@ -9,12 +10,229 @@ -- This file defines the V9 Baserock Yaml Schema in Haskell -- ----------------------------------------------------------------------------- -module Baserock.Schema.V9 ( +module Baserock.Schema.V9 + ( module Data.Yaml.Pretty.Extras + , - module Baserock.Schema.V9.Data, - module Baserock.Schema.V9.Database + -- * Schema + ChunkInstructions(..) + , Chunk(..) + , StratumBD(..) + , StratumInclude(..) + , Stratum(..) + , System(..) + , -) where + -- * Lenses + chunkInstructionsName + , buildSystem + , preConfigureCommands + , configureCommands + , postConfigureCommands + , preBuildCommands + , buildCommands + , postBuildCommands + , preInstallCommands + , installCommands + , postInstallCommands + , chunkName + , chunkMorph + , repo + , ref + , sha + , buildMode + , chunkBuildSystem + , stratumBDMorph + , stratumName + , stratumDescription + , stratumBDs + , chunks + , stratumIncludeName + , stratumIncludeMorph + , systemName + , systemDescription + , arch + , strata + , configurationExtensions + ) +where -import Baserock.Schema.V9.Data -import Baserock.Schema.V9.Database +import Data.Yaml.Pretty.Extras +import Lens.Micro.Platform hiding ( (.=) ) +import RIO +import RIO.List +import qualified RIO.Text as Text + +possibly f v = if v == mzero then mzero else [f .= v] + +-- * ChunkInstructions + +data ChunkInstructions = ChunkInstructions { + _chunkInstructionsName :: Text, + _buildSystem :: Text, + _preConfigureCommands :: [Text], + _configureCommands :: [Text], + _postConfigureCommands :: [Text], + _preBuildCommands :: [Text], + _buildCommands :: [Text], + _postBuildCommands :: [Text], + _preInstallCommands :: [Text], + _installCommands :: [Text], + _postInstallCommands :: [Text] +} deriving (Eq, Show) + +$(makeLenses ''ChunkInstructions) + +instance FromJSON ChunkInstructions where + parseJSON (Object v) = ChunkInstructions + <$> v .: "name" + <*> v .:? "build-system" .!= "manual" + <*> v .:? "pre-configure-commands" .!= [] + <*> v .:? "configure-commands" .!= [] + <*> v .:? "post-configure-commands" .!= [] + <*> v .:? "pre-build-commands" .!= [] + <*> v .:? "build-commands" .!= [] + <*> v .:? "post-build-commands" .!= [] + <*> v .:? "pre-install-commands" .!= [] + <*> v .:? "install-commands" .!= [] + <*> v .:? "post-install-commands" .!= [] + +instance ToJSON ChunkInstructions where + toJSON x = + object $ ["name" .= _chunkInstructionsName x, "kind" .= ("chunk" :: Text), "build-system" .= _buildSystem x] + <> possibly "pre-configure-commands" (_preConfigureCommands x) + <> possibly "configure-commands" (_configureCommands x) + <> possibly "post-configure-commands" (_postConfigureCommands x) + <> possibly "pre-build-commands" (_preBuildCommands x) + <> possibly "build-commands" (_buildCommands x) + <> possibly "post-build-commands" (_postBuildCommands x) + <> possibly "pre-install-commands" (_preInstallCommands x) + <> possibly "install-commands" (_installCommands x) + <> possibly "post-install-commands" (_postInstallCommands x) + +instance ToPrettyYaml ChunkInstructions where + fieldOrder = const $ ["name", "kind", "build-system"] + <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x] + <> ["rpm-metadata"] + + +-- Stratum ("stratum.morph") + +data Chunk = Chunk { + _chunkName :: Text, + _chunkMorph :: Maybe Text, + _repo :: Maybe Text, + _ref :: Maybe Text, + _sha :: Maybe Text, + _buildMode :: Text, + _chunkBuildSystem :: Text, + _chunkBDs :: [Text] +} deriving (Eq, Show) + +$(makeLenses ''Chunk) + +instance FromJSON Chunk where + parseJSON (Object v) = Chunk + <$> v .: "name" + <*> v .:? "morph" + <*> v .:? "repo" + <*> v .:? "ref" + <*> v .:? "sha" + <*> v .:? "build-mode" .!= "staging" + <*> v .:? "build-system" .!= "manual" + <*> v .:? "build-depends" .!= [] + +instance ToJSON Chunk where + toJSON x = object $ ["name" .= _chunkName x, "repo" .= _repo x, "ref" .= _ref x, "sha" .= _sha x] + <> possibly "morph" (_chunkMorph x) + <> (if _buildMode x == "staging" then mempty else ["build-mode" .= _buildMode x]) + <> (if _chunkBuildSystem x == "manual" then mempty else ["build-system" .= _chunkBuildSystem x]) + <> possibly "build-depends" (_chunkBDs x) + +instance ToPrettyYaml Chunk where + fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"] + +newtype StratumBD = StratumBD { + _stratumBDMorph :: Text +} deriving (Eq, Show) + +$(makeLenses ''StratumBD) + +instance FromJSON StratumBD where + parseJSON (Object v) = StratumBD + <$> v .: "morph" + +instance ToJSON StratumBD where + toJSON x = object ["morph" .= _stratumBDMorph x] + +instance ToPrettyYaml StratumBD where + fieldOrder = const ["morph"] + +data Stratum = Stratum { + _stratumName :: Text, + _stratumDescription :: Maybe Text, + _stratumBDs :: [StratumBD], + _chunks :: [Chunk] +} deriving (Eq, Show) + +$(makeLenses ''Stratum) + +instance FromJSON Stratum where + parseJSON (Object v) = Stratum + <$> v .: "name" + <*> v .:? "description" + <*> v .:? "build-depends" .!= [] + <*> v .: "chunks" + +instance ToJSON Stratum where + toJSON x = object $ ["name" .= _stratumName x, "kind" .= ("stratum" :: Text), "chunks" .= _chunks x] + <> possibly "description" (_stratumDescription x) + <> possibly "build-depends" (_stratumBDs x) + +instance ToPrettyYaml Stratum where + fieldOrder = const ["name", "kind", "description", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"] + +-- System ("system.morph") + +data StratumInclude = StratumInclude { + _stratumIncludeName :: Text, + _stratumIncludeMorph :: Text +} deriving (Eq, Show) + +$(makeLenses ''StratumInclude) + +instance FromJSON StratumInclude where + parseJSON (Object v) = StratumInclude + <$> v .: "name" + <*> v .: "morph" + +instance ToJSON StratumInclude where + toJSON x = object ["name" .= _stratumIncludeName x, "morph" .= _stratumIncludeMorph x] + +instance ToPrettyYaml StratumInclude where + fieldOrder = const ["name", "morph"] + +data System = System { + _systemName :: Text, + _systemDescription :: Maybe Text, + _arch :: Text, + _strata :: [StratumInclude], + _configurationExtensions :: [Text] +} deriving (Eq, Show) + +$(makeLenses ''System) + +instance FromJSON System where + parseJSON (Object v) = System + <$> v .: "name" + <*> v .:? "description" + <*> v .: "arch" + <*> v .: "strata" + <*> v .: "configuration-extensions" + +instance ToJSON System where + toJSON x = object $ ["name" .= _systemName x, "kind" .= ("system" :: Text), "arch" .= _arch x, "strata" .= _strata x, "configuration-extensions" .= _configurationExtensions x] + <> possibly "description" (_systemDescription x) + +instance ToPrettyYaml System where + fieldOrder = const ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"] diff --git a/src/Baserock/Schema/V9/Data.hs b/src/Baserock/Schema/V9/Data.hs deleted file mode 100644 --- a/src/Baserock/Schema/V9/Data.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Baserock.Schema.V9.Data --- Copyright : (c) Daniel Firth 2018 --- License : BSD3 --- Maintainer : locallycompact@gmail.com --- Stability : experimental --- --- This file defines the V9 Baserock Yaml Schema in Haskell --- ------------------------------------------------------------------------------ -module Baserock.Schema.V9.Data - ( module Data.Yaml.Pretty.Extras - , - - -- * Schema - ChunkInstructions(..) - , Chunk(..) - , StratumBD(..) - , StratumInclude(..) - , Stratum(..) - , System(..) - , - - -- * Lenses - chunkInstructionsName - , buildSystem - , preConfigureCommands - , configureCommands - , postConfigureCommands - , preBuildCommands - , buildCommands - , postBuildCommands - , preInstallCommands - , installCommands - , postInstallCommands - , chunkName - , chunkMorph - , repo - , ref - , sha - , buildMode - , chunkBuildSystem - , stratumBDMorph - , stratumName - , stratumDescription - , stratumBDs - , chunks - , stratumIncludeName - , stratumIncludeMorph - , systemName - , systemDescription - , arch - , strata - , configurationExtensions - ) -where - -import Data.Yaml.Pretty.Extras -import Lens.Micro.Platform hiding ( (.=) ) -import RIO -import RIO.List -import qualified RIO.Text as Text - -possibly f v = if v == mzero then mzero else [f .= v] - --- * ChunkInstructions - -data ChunkInstructions = ChunkInstructions { - _chunkInstructionsName :: Text, - _buildSystem :: Text, - _preConfigureCommands :: [Text], - _configureCommands :: [Text], - _postConfigureCommands :: [Text], - _preBuildCommands :: [Text], - _buildCommands :: [Text], - _postBuildCommands :: [Text], - _preInstallCommands :: [Text], - _installCommands :: [Text], - _postInstallCommands :: [Text] -} deriving (Eq, Show) - -$(makeLenses ''ChunkInstructions) - -instance FromJSON ChunkInstructions where - parseJSON (Object v) = ChunkInstructions - <$> v .: "name" - <*> v .:? "build-system" .!= "manual" - <*> v .:? "pre-configure-commands" .!= [] - <*> v .:? "configure-commands" .!= [] - <*> v .:? "post-configure-commands" .!= [] - <*> v .:? "pre-build-commands" .!= [] - <*> v .:? "build-commands" .!= [] - <*> v .:? "post-build-commands" .!= [] - <*> v .:? "pre-install-commands" .!= [] - <*> v .:? "install-commands" .!= [] - <*> v .:? "post-install-commands" .!= [] - -instance ToJSON ChunkInstructions where - toJSON x = - object $ ["name" .= _chunkInstructionsName x, "kind" .= ("chunk" :: Text), "build-system" .= _buildSystem x] - <> possibly "pre-configure-commands" (_preConfigureCommands x) - <> possibly "configure-commands" (_configureCommands x) - <> possibly "post-configure-commands" (_postConfigureCommands x) - <> possibly "pre-build-commands" (_preBuildCommands x) - <> possibly "build-commands" (_buildCommands x) - <> possibly "post-build-commands" (_postBuildCommands x) - <> possibly "pre-install-commands" (_preInstallCommands x) - <> possibly "install-commands" (_installCommands x) - <> possibly "post-install-commands" (_postInstallCommands x) - -instance ToPrettyYaml ChunkInstructions where - fieldOrder = const $ ["name", "kind", "build-system"] - <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x] - <> ["rpm-metadata"] - - --- Stratum ("stratum.morph") - -data Chunk = Chunk { - _chunkName :: Text, - _chunkMorph :: Maybe Text, - _repo :: Text, - _ref :: Text, - _sha :: Maybe Text, - _buildMode :: Text, - _chunkBuildSystem :: Text, - _chunkBDs :: [Text] -} deriving (Eq, Show) - -$(makeLenses ''Chunk) - -instance FromJSON Chunk where - parseJSON (Object v) = Chunk - <$> v .: "name" - <*> v .:? "morph" - <*> v .: "repo" - <*> v .: "ref" - <*> v .:? "sha" - <*> v .:? "build-mode" .!= "staging" - <*> v .:? "build-system" .!= "manual" - <*> v .:? "build-depends" .!= [] - -instance ToJSON Chunk where - toJSON x = object $ ["name" .= _chunkName x, "repo" .= _repo x, "ref" .= _ref x, "sha" .= _sha x] - <> possibly "morph" (_chunkMorph x) - <> (if _buildMode x == "staging" then mempty else ["buildmode" .= _buildMode x]) - <> (if _chunkBuildSystem x == "manual" then mempty else ["build-system" .= _chunkBuildSystem x]) - <> possibly "build-depends" (_chunkBDs x) - -instance ToPrettyYaml Chunk where - fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"] - -newtype StratumBD = StratumBD { - _stratumBDMorph :: Text -} deriving (Eq, Show) - -$(makeLenses ''StratumBD) - -instance FromJSON StratumBD where - parseJSON (Object v) = StratumBD - <$> v .: "morph" - -instance ToJSON StratumBD where - toJSON x = object ["morph" .= _stratumBDMorph x] - -instance ToPrettyYaml StratumBD where - fieldOrder = const ["morph"] - -data Stratum = Stratum { - _stratumName :: Text, - _stratumDescription :: Maybe Text, - _stratumBDs :: [StratumBD], - _chunks :: [Chunk] -} deriving (Eq, Show) - -$(makeLenses ''Stratum) - -instance FromJSON Stratum where - parseJSON (Object v) = Stratum - <$> v .: "name" - <*> v .:? "description" - <*> v .:? "build-depends" .!= [] - <*> v .: "chunks" - -instance ToJSON Stratum where - toJSON x = object $ ["name" .= _stratumName x, "kind" .= ("stratum" :: Text), "chunks" .= _chunks x] - <> possibly "description" (_stratumDescription x) - <> possibly "build-depends" (_stratumBDs x) - -instance ToPrettyYaml Stratum where - fieldOrder = const ["name", "kind", "description", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"] - --- System ("system.morph") - -data StratumInclude = StratumInclude { - _stratumIncludeName :: Text, - _stratumIncludeMorph :: Text -} deriving (Eq, Show) - -$(makeLenses ''StratumInclude) - -instance FromJSON StratumInclude where - parseJSON (Object v) = StratumInclude - <$> v .: "name" - <*> v .: "morph" - -instance ToJSON StratumInclude where - toJSON x = object ["name" .= _stratumIncludeName x, "morph" .= _stratumIncludeMorph x] - -instance ToPrettyYaml StratumInclude where - fieldOrder = const ["name", "morph"] - -data System = System { - _systemName :: Text, - _systemDescription :: Maybe Text, - _arch :: Text, - _strata :: [StratumInclude], - _configurationExtensions :: [Text] -} deriving (Eq, Show) - -$(makeLenses ''System) - -instance FromJSON System where - parseJSON (Object v) = System - <$> v .: "name" - <*> v .:? "description" - <*> v .: "arch" - <*> v .: "strata" - <*> v .: "configuration-extensions" - -instance ToJSON System where - toJSON x = object $ ["name" .= _systemName x, "kind" .= ("system" :: Text), "arch" .= _arch x, "strata" .= _strata x, "configuration-extensions" .= _configurationExtensions x] - <> possibly "description" (_systemDescription x) - -instance ToPrettyYaml System where - fieldOrder = const ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"] diff --git a/src/Baserock/Schema/V9/Database.hs b/src/Baserock/Schema/V9/Database.hs deleted file mode 100644 --- a/src/Baserock/Schema/V9/Database.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------------ --- | --- Module : Baserock.Schema.V9.Database --- Copyright : (c) Daniel Firth 2018 --- License : BSD3 --- Maintainer : locallycompact@gmail.com --- Stability : experimental --- --- This file defines the V9 Baserock Yaml Schema in Haskell --- ------------------------------------------------------------------------------ -module Baserock.Schema.V9.Database - ( Definitions(..) - , loadSystem - , loadMorphInto - , defSystems - , defStrata - , defChunks - , expandAliases - , contractAliases - ) -where - -import Algebra.Graph -import Baserock.Schema.V9.Data -import Control.Monad.State -import Data.Function.Flippers -import Data.Typeable -import Lens.Micro.Platform -import RIO -import RIO.List -import qualified RIO.ByteString as BS -import qualified RIO.HashMap as HM -import qualified RIO.Text as Text -import qualified RIO.Text.Partial as TextP - -data Definitions = Definitions { - _defSystems :: HashMap Text System, - _defStrata :: HashMap Text Stratum, - _defChunks :: HashMap Text ChunkInstructions -} deriving (Eq, Show) - -instance Semigroup Definitions where - Definitions x1 x2 x3 <> Definitions y1 y2 y3 = Definitions (x1 <> y1) (x2 <> y2) (x3 <> y3) - -instance Monoid Definitions where - mempty = Definitions mempty mempty mempty - -$(makeLenses ''Definitions) - -loadMorphInto - :: ( MonadIO m - , MonadReader env m - , HasLogFunc env - , FromJSON b - , ToPrettyYaml b - , Typeable b - , MonadThrow m - , MonadState s m - ) - => RIO.ASetter s s (HashMap Text b) (HashMap Text b) - -> FilePath - -> m b -loadMorphInto f x = do - (t :: b) <- decodeFileThrowLogged x - f %= HM.insert (Text.pack x) t - return t - -expandSystem = - mapM (loadMorphInto defStrata . Text.unpack . _stratumIncludeMorph) . _strata - -expandStratum = - mapM (loadMorphInto defChunks . Text.unpack) . mapMaybe _chunkMorph . _chunks - -loadSystem - :: ( MonadReader env m - , MonadIO m - , MonadThrow m - , MonadState Definitions m - , HasLogFunc env - ) - => FilePath - -> m System -loadSystem f = do - s <- loadMorphInto defSystems f - (expandSystem >=> mapM expandStratum) s - return s - -expandAliases = - over (chunks . traverse . repo) . flip (HM.foldrWithKey TextP.replace) - -contractAliases = over (chunks . traverse . repo) - . flip (HM.foldlWithKey' (flip3 TextP.replace)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,5 @@ import Baserock.Schema.V9 -import Control.Error -import Data.Yaml +import Data.Yaml.Pretty.Extras import RIO import RIO.Directory import qualified RIO.ByteString as BS @@ -43,10 +42,10 @@ { _chunkName = "brie-cc" , _buildMode = "staging" , _chunkBuildSystem = "manual" - , _repo = "gitlab:brie-cc" + , _repo = Just "gitlab:brie-cc" , _chunkMorph = Just "quux/strata/grilled-essential/brie-cc.morph" - , _ref = "foo" + , _ref = Just "foo" , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba" , _chunkBDs = [] } @@ -54,10 +53,10 @@ { _chunkName = "linux-api-headers" , _buildMode = "staging" , _chunkBuildSystem = "manual" - , _repo = "gitlab:kernel/linux-stable" + , _repo = Just "gitlab:kernel/linux-stable" , _chunkMorph = Just "quux/strata/grilled-essential/linux-api-headers.morph" - , _ref = "bar" + , _ref = Just "bar" , _sha = Just "9db87049dd8b357bf9be97f6394b5251e8606fe2" , _chunkBDs = ["brie-cc"] } @@ -103,9 +102,9 @@ { _chunkName = "ccake" , _buildMode = "staging" , _chunkBuildSystem = "manual" - , _repo = "gitlab:upstream/ccake" + , _repo = Just "gitlab:upstream/ccake" , _chunkMorph = Just "quux/strata/core/ccake.morph" - , _ref = "master" + , _ref = Just "master" , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba" , _chunkBDs = [] } @@ -113,9 +112,9 @@ { _chunkName = "sesame-sed" , _buildMode = "staging" , _chunkBuildSystem = "manual" - , _repo = "gitlab:upstream/sesame-sed" + , _repo = Just "gitlab:upstream/sesame-sed" , _chunkMorph = Just "quux/strata/core/sesame-sed.morph" - , _ref = "master" + , _ref = Just "master" , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba" , _chunkBDs = ["ccake"] }