baserock-schema 0.0.1.5 → 0.0.2.0
raw patch · 7 files changed
+604/−518 lines, 7 filesdep +flippersdep +microlens-platformdep +riodep −lensdep −textdep −transformers
Dependencies added: flippers, microlens-platform, rio, yaml-pretty-extras
Dependencies removed: lens, text, transformers, turtle, unordered-containers
Files
- ChangeLog.md +6/−0
- app/Main.hs +47/−36
- baserock-schema.cabal +19/−19
- src/Baserock/Schema/V9.hs +4/−311
- src/Baserock/Schema/V9/Data.hs +238/−0
- src/Baserock/Schema/V9/Database.hs +95/−0
- test/Spec.hs +195/−152
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for baserock-schema +## 0.0.2.0 (PreAlpha)++Switch to use RIO for main loading systems+Add basic MonadState database for Definitions+Example sanitizer+ ## 0.0.1.5 (PreAlpha) * Fix some schema issues.
app/Main.hs view
@@ -1,21 +1,20 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-} -import Baserock.Schema.V9-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Control.Exception-import Control.Lens hiding (argument)-import Control.Monad (when)-import Control.Monad.Except-import Data.Char (toUpper)-import Data.HashMap.Strict-import Data.List-import qualified Data.Text as Text-import Data.Yaml-import Gitlab-import System.Environment (getEnv, getArgs)-import System.Console.Docopt+import Baserock.Schema.V9+import Control.Monad.State+import Gitlab+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 patterns :: Docopt patterns = [docopt|@@ -34,32 +33,44 @@ getAliases ybdconf = do ybdconf <- decodeFile ybdconf :: IO (Maybe Object)- let Just (Object as) = join $ parseMaybe (flip (.:) "aliases") <$> ybdconf :: Maybe Value- return $ fmap (\(String y) -> y) $ as+ let Just (Object as) = parseMaybe (.: "aliases") =<< ybdconf :: Maybe Value+ return $ (\(String y) -> y) <$> as -toSignificantSuffix = (!! 1) . Text.splitOn ":"+toSignificantSuffix = (!! 1) . TextP.splitOn ":" +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+ main = do- args <- parseArgsOrExit patterns =<< getArgs+ args <- parseArgsOrExit patterns =<< getArgs + logOptions <- logOptionsHandle stdout True+ when (args `isPresent` command "sanitize") $ do- f <- args `getArgOrExit` (argument "system")- s <- decodeSystemAST f- case s of- Right r -> encodeSystemAST f r- Left e -> throwIO e+ f <- args `getArgOrExit` argument "system"+ withLogFunc logOptions $ flip runRIO $+ void $ flip execStateT mempty $ sanitize f when (args `isPresent` command "bump-shas") $ do- f <- args `getArgOrExit` (argument "stratum")- envPrivateToken <- getEnv "GITLAB_PRIVATE_TOKEN"- envBaseUrl <- getEnv "GITLAB_BASE_URL"+ f <- args `getArgOrExit` argument "stratum"+ envPrivateToken <- getEnv "GITLAB_PRIVATE_TOKEN"+ envBaseUrl <- getEnv "GITLAB_BASE_URL" - aliases <- getAliases "ybd.conf"+ aliases <- getAliases "ybd.conf" - let gconf = GitlabConfig { glCredsUrl = BS8.pack envBaseUrl, glCredsToken = BS8.pack envPrivateToken }+ let gconf = GitlabConfig+ { glCredsUrl = fromString envBaseUrl+ , glCredsToken = fromString envPrivateToken+ } - s <- either (error . show) id <$> decodeFileEither f- let s2 = over (chunks . traverse . repo) (flip (foldrWithKey Text.replace) aliases) s- r <- runGitlab gconf $ mapMOf (chunks . traverse) bumpChunkSha $ s2- let s3 = over (chunks . traverse . repo) (flip (foldlWithKey' ((flip . (flip . ) . flip) Text.replace)) aliases) r- BS.writeFile f (toPrettyYaml s3)+ 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
baserock-schema.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c8c8db858030e83a98af816533ab7595e6c4e6052ce82f2a8c9baaa249dac1af+-- hash: 92f2b3a2df36fec782d09691a9d06d723cb278e0aec4142eb412bd9fde8753b7 name: baserock-schema-version: 0.0.1.5+version: 0.0.2.0 synopsis: Baserock Definitions Schema description: Baserock Definitions Schema - Parsers, Printers, Encoders, Decoders, ASTs, Graphs and Traversals category: Data@@ -28,22 +28,23 @@ 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 , base >=4.7 && <5- , bytestring , errors- , lens+ , flippers+ , microlens-platform , mtl- , text- , transformers- , turtle- , unordered-containers+ , rio , yaml+ , yaml-pretty-extras default-language: Haskell2010 executable baserock@@ -52,22 +53,21 @@ Paths_baserock_schema hs-source-dirs: app+ 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 , base >=4.7 && <5 , baserock-schema- , bytestring , docopt , errors+ , flippers , gitlab-api- , lens+ , microlens-platform , mtl- , text- , transformers- , turtle- , unordered-containers+ , rio , yaml+ , yaml-pretty-extras default-language: Haskell2010 test-suite earthquake-test@@ -77,6 +77,7 @@ Paths_baserock_schema hs-source-dirs: test+ 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: QuickCheck@@ -85,12 +86,11 @@ , baserock-schema , bytestring , errors+ , flippers , hspec- , lens+ , microlens-platform , mtl- , text- , transformers- , turtle- , unordered-containers+ , rio , yaml+ , yaml-pretty-extras default-language: Haskell2010
src/Baserock/Schema/V9.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}- ----------------------------------------------------------------------------- -- | -- Module : Baserock.Schema.V9@@ -14,314 +11,10 @@ ----------------------------------------------------------------------------- module Baserock.Schema.V9 ( - -- * 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,-- -- * ASTs-- StratumAST,- SystemAST,-- -- * Codecs- - encodeStratumAST,- decodeStratumAST,- encodeSystemAST,- decodeSystemAST,-- -- * Misc- - encodeFilePretty,- ToPrettyYaml(..)+ module Baserock.Schema.V9.Data,+ module Baserock.Schema.V9.Database ) where -import Algebra.Graph-import Control.Arrow-import Control.Applicative-import Control.Error.Safe-import Control.Error.Util-import Control.Lens.TH-import Control.Monad-import Control.Monad.Except-import qualified Data.ByteString as BS-import Data.Ord-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text, unpack)-import Data.Yaml-import Data.Yaml.Pretty--listElemCmp as x y = fromMaybe LT $ liftA2 compare (elemIndex x as) (elemIndex y as)--possibly f v = if v == mzero then mzero else [f .= v]--class ToJSON a => ToPrettyYaml a where- fieldOrder :: a -> [Text]-- fieldCmp :: a -> (Text -> Text -> Ordering)- fieldCmp = listElemCmp . fieldOrder-- toPrettyYaml :: a -> BS.ByteString- toPrettyYaml x = encodePretty (setConfCompare (fieldCmp x) defConfig) x--encodeFilePretty :: ToPrettyYaml a => FilePath -> a -> IO ()-encodeFilePretty f x = BS.writeFile f (toPrettyYaml x)---- * 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"]--data 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"]----- Decoders--type StratumAST = (Stratum, [(FilePath, ChunkInstructions)])-type SystemAST = (System, [(FilePath, StratumAST)])--splitK a b = runKleisli $ Kleisli a &&& Kleisli b--decodeASTWith selector decoder x = runExceptT $ withExceptT (\e -> AesonException ("Error in " ++ x ++ ": " ++ show e)) $ do- (ExceptT . decodeFileEither $ x) >>= splitK return (mapM (splitK return decoder) . selector)--decodeStratumAST :: FilePath -> IO (Either ParseException StratumAST)-decodeStratumAST = decodeASTWith (fmap unpack . mapMaybe _chunkMorph . _chunks) (ExceptT . decodeFileEither)--decodeSystemAST :: FilePath -> IO (Either ParseException SystemAST)-decodeSystemAST = decodeASTWith (fmap (unpack . _stratumIncludeMorph) . _strata) (ExceptT . decodeStratumAST)---- Encoders--encodeStratumAST :: FilePath -> StratumAST -> IO ()-encodeStratumAST f (x, as) = do- encodeFilePretty f x- forM_ as $ uncurry encodeFilePretty--encodeSystemAST :: FilePath -> SystemAST -> IO ()-encodeSystemAST f (x, as) = do- encodeFilePretty f x- forM_ as $ uncurry encodeStratumAST---- Utility--data BaserockGraphException = NoExistChunkBD Chunk Text- | NoExistStratumBD Stratum Text deriving Show--stratumGraph :: Stratum -> Either BaserockGraphException (Graph Chunk)-stratumGraph s = right edges $ sequence $ runExceptT $ do- x <- ExceptT (fmap Right $ _chunks s)- y <- ExceptT (fmap Right $ _chunkBDs x)- z <- failWith (NoExistChunkBD x y) $ find ((== y) . _chunkName) (_chunks s)- return (z, x)---- V9 is non-regular in that graphs of Strata can be derived purely from the Stratum itself--- where as graphs of Systems require a SystemAST. We aim to correct this.+import Baserock.Schema.V9.Data+import Baserock.Schema.V9.Database
+ src/Baserock/Schema/V9/Data.hs view
@@ -0,0 +1,238 @@+{-# 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"]
+ src/Baserock/Schema/V9/Database.hs view
@@ -0,0 +1,95 @@+{-# 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))
test/Spec.hs view
@@ -1,171 +1,214 @@-{-# LANGUAGE OverloadedStrings #-}--import Test.Hspec-import Test.QuickCheck-import qualified Data.ByteString as BS-import Baserock.Schema.V9-import Control.Exception (throwIO, evaluate, bracket_)-import Control.Monad.Except-import Data.Yaml-import Turtle+import Baserock.Schema.V9+import Control.Error+import Data.Yaml+import RIO+import RIO.Directory+import qualified RIO.ByteString as BS+import Test.Hspec+import Test.QuickCheck -v9_mock_chunk_instructions_brie_cc = ChunkInstructions {- _chunkInstructionsName = "brie-cc",- _buildSystem = "autotools",- _preConfigureCommands = ["make configure"],- _configureCommands = [],- _postConfigureCommands = [],- _preBuildCommands = [],- _buildCommands = ["make all"],- _postBuildCommands = [],- _preInstallCommands = [],- _installCommands = [],- _postInstallCommands = []-}+v9_mock_chunk_instructions_brie_cc = ChunkInstructions+ { _chunkInstructionsName = "brie-cc"+ , _buildSystem = "autotools"+ , _preConfigureCommands = ["make configure"]+ , _configureCommands = []+ , _postConfigureCommands = []+ , _preBuildCommands = []+ , _buildCommands = ["make all"]+ , _postBuildCommands = []+ , _preInstallCommands = []+ , _installCommands = []+ , _postInstallCommands = []+ } -v9_mock_chunk_instructions_linux_api_headers = ChunkInstructions {- _chunkInstructionsName = "linux-api-headers",- _buildSystem = "autotools",- _preConfigureCommands = ["make configure"],- _configureCommands = [],- _postConfigureCommands = [],- _preBuildCommands = [],- _buildCommands = ["make all"],- _postBuildCommands = [],- _preInstallCommands = [],- _installCommands = [],- _postInstallCommands = []-}+v9_mock_chunk_instructions_linux_api_headers = ChunkInstructions+ { _chunkInstructionsName = "linux-api-headers"+ , _buildSystem = "autotools"+ , _preConfigureCommands = ["make configure"]+ , _configureCommands = []+ , _postConfigureCommands = []+ , _preBuildCommands = []+ , _buildCommands = ["make all"]+ , _postBuildCommands = []+ , _preInstallCommands = []+ , _installCommands = []+ , _postInstallCommands = []+ } -v9_mock_stratum_grilled_essential = Stratum {- _stratumName = "grilled-essential",- _stratumDescription = Nothing,- _stratumBDs = [ ],- _chunks = [ Chunk { _chunkName = "brie-cc",- _buildMode = "staging",- _chunkBuildSystem = "manual",- _repo = "gitlab:brie-cc",- _chunkMorph = Just "quux/strata/grilled-essential/brie-cc.morph",- _ref = "foo",- _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba",- _chunkBDs = [] },- Chunk { _chunkName = "linux-api-headers", - _buildMode = "staging",- _chunkBuildSystem = "manual",- _repo = "gitlab:kernel/linux-stable",- _chunkMorph = Just "quux/strata/grilled-essential/linux-api-headers.morph",- _ref = "bar",- _sha = Just "9db87049dd8b357bf9be97f6394b5251e8606fe2",- _chunkBDs = [ "brie-cc" ] } ]}+v9_mock_stratum_grilled_essential = Stratum+ { _stratumName = "grilled-essential"+ , _stratumDescription = Nothing+ , _stratumBDs = []+ , _chunks = [ Chunk+ { _chunkName = "brie-cc"+ , _buildMode = "staging"+ , _chunkBuildSystem = "manual"+ , _repo = "gitlab:brie-cc"+ , _chunkMorph = Just+ "quux/strata/grilled-essential/brie-cc.morph"+ , _ref = "foo"+ , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba"+ , _chunkBDs = []+ }+ , Chunk+ { _chunkName = "linux-api-headers"+ , _buildMode = "staging"+ , _chunkBuildSystem = "manual"+ , _repo = "gitlab:kernel/linux-stable"+ , _chunkMorph = Just+ "quux/strata/grilled-essential/linux-api-headers.morph"+ , _ref = "bar"+ , _sha = Just "9db87049dd8b357bf9be97f6394b5251e8606fe2"+ , _chunkBDs = ["brie-cc"]+ }+ ]+ } -v9_mock_chunk_instructions_ccake = ChunkInstructions {- _chunkInstructionsName = "ccake",- _buildSystem = "autotools",- _preConfigureCommands = ["make configure"],- _configureCommands = [],- _postConfigureCommands = [],- _preBuildCommands = [],- _buildCommands = ["make all"],- _postBuildCommands = [],- _preInstallCommands = [],- _installCommands = [],- _postInstallCommands = []-}+v9_mock_chunk_instructions_ccake = ChunkInstructions+ { _chunkInstructionsName = "ccake"+ , _buildSystem = "autotools"+ , _preConfigureCommands = ["make configure"]+ , _configureCommands = []+ , _postConfigureCommands = []+ , _preBuildCommands = []+ , _buildCommands = ["make all"]+ , _postBuildCommands = []+ , _preInstallCommands = []+ , _installCommands = []+ , _postInstallCommands = []+ } -v9_mock_chunk_instructions_sesame_sed = ChunkInstructions {- _chunkInstructionsName = "sesame-sed",- _buildSystem = "autotools",- _preConfigureCommands = ["make configure"],- _configureCommands = [],- _postConfigureCommands = [],- _preBuildCommands = [],- _buildCommands = ["make all"],- _postBuildCommands = [],- _preInstallCommands = [],- _installCommands = [],- _postInstallCommands = []-}+v9_mock_chunk_instructions_sesame_sed = ChunkInstructions+ { _chunkInstructionsName = "sesame-sed"+ , _buildSystem = "autotools"+ , _preConfigureCommands = ["make configure"]+ , _configureCommands = []+ , _postConfigureCommands = []+ , _preBuildCommands = []+ , _buildCommands = ["make all"]+ , _postBuildCommands = []+ , _preInstallCommands = []+ , _installCommands = []+ , _postInstallCommands = []+ } -v9_mock_stratum_core = Stratum {- _stratumName = "core",- _stratumDescription = Nothing,- _stratumBDs = [ StratumBD { _stratumBDMorph = "quux/strata/grilled-essential.morph" }],- _chunks = [ Chunk { _chunkName = "ccake",- _buildMode = "staging",- _chunkBuildSystem = "manual",- _repo = "gitlab:upstream/ccake",- _chunkMorph = Just "quux/strata/core/ccake.morph",- _ref = "master",- _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba",- _chunkBDs = [] },- Chunk { _chunkName = "sesame-sed", - _buildMode = "staging",- _chunkBuildSystem = "manual",- _repo = "gitlab:upstream/sesame-sed",- _chunkMorph = Just "quux/strata/core/sesame-sed.morph",- _ref = "master",- _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba",- _chunkBDs = [ "ccake" ] } ]}+v9_mock_stratum_core = Stratum+ { _stratumName = "core"+ , _stratumDescription = Nothing+ , _stratumBDs = [ StratumBD+ { _stratumBDMorph = "quux/strata/grilled-essential.morph"+ }+ ]+ , _chunks = [ Chunk+ { _chunkName = "ccake"+ , _buildMode = "staging"+ , _chunkBuildSystem = "manual"+ , _repo = "gitlab:upstream/ccake"+ , _chunkMorph = Just "quux/strata/core/ccake.morph"+ , _ref = "master"+ , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba"+ , _chunkBDs = []+ }+ , Chunk+ { _chunkName = "sesame-sed"+ , _buildMode = "staging"+ , _chunkBuildSystem = "manual"+ , _repo = "gitlab:upstream/sesame-sed"+ , _chunkMorph = Just "quux/strata/core/sesame-sed.morph"+ , _ref = "master"+ , _sha = Just "0c3506aa4f33da7fc2fba0fd6b614bf8e861e3ba"+ , _chunkBDs = ["ccake"]+ }+ ]+ } -v9_mock_system_quux = System {- _systemName = "quux-system-x86_32",- _systemDescription = Nothing,- _arch = "x86_32",- _strata = [ StratumInclude { _stratumIncludeName = "grilled-essential", _stratumIncludeMorph = "quux/strata/grilled-essential.morph" },- StratumInclude { _stratumIncludeName = "core", _stratumIncludeMorph = "quux/strata/core.morph" } ],- _configurationExtensions = ["extensions/smooth-and-creamy"]}+v9_mock_system_quux = System+ { _systemName = "quux-system-x86_32"+ , _systemDescription = Nothing+ , _arch = "x86_32"+ , _strata = [ StratumInclude+ { _stratumIncludeName = "grilled-essential"+ , _stratumIncludeMorph = "quux/strata/grilled-essential.morph"+ }+ , StratumInclude+ { _stratumIncludeName = "core"+ , _stratumIncludeMorph = "quux/strata/core.morph"+ }+ ]+ , _configurationExtensions = ["extensions/smooth-and-creamy"]+ } -v9_mock_stratum_grilled_essential_ast = (v9_mock_stratum_grilled_essential,- [("quux/strata/grilled-essential/brie-cc.morph", v9_mock_chunk_instructions_brie_cc),- ("quux/strata/grilled-essential/linux-api-headers.morph", v9_mock_chunk_instructions_linux_api_headers)])+v9_mock_stratum_grilled_essential_ast =+ ( v9_mock_stratum_grilled_essential+ , [ ( "quux/strata/grilled-essential/brie-cc.morph"+ , v9_mock_chunk_instructions_brie_cc+ )+ , ( "quux/strata/grilled-essential/linux-api-headers.morph"+ , v9_mock_chunk_instructions_linux_api_headers+ )+ ]+ ) -v9_mock_stratum_core_ast = (v9_mock_stratum_core,- [("quux/strata/core/ccake.morph", v9_mock_chunk_instructions_ccake),- ("quux/strata/core/sesame-sed.morph", v9_mock_chunk_instructions_sesame_sed)])+v9_mock_stratum_core_ast =+ ( v9_mock_stratum_core+ , [ ("quux/strata/core/ccake.morph", v9_mock_chunk_instructions_ccake)+ , ( "quux/strata/core/sesame-sed.morph"+ , v9_mock_chunk_instructions_sesame_sed+ )+ ]+ ) -v9_mock_system_quux_ast = (v9_mock_system_quux,- [("quux/strata/grilled-essential.morph", v9_mock_stratum_grilled_essential_ast),- ("quux/strata/core.morph", v9_mock_stratum_core_ast)])+v9_mock_system_quux_ast =+ ( v9_mock_system_quux+ , [ ( "quux/strata/grilled-essential.morph"+ , v9_mock_stratum_grilled_essential_ast+ )+ , ("quux/strata/core.morph", v9_mock_stratum_core_ast)+ ]+ ) -in_mock_definitions_v9 = bracket_ (cd "test/mock-definitions-v9") (cd "../../")+in_mock_definitions_v9 =+ around_ $ withCurrentDirectory "test/mock-definitions-v9" -testDecodeAgainst x y = either (error . show) id <$> decodeFileEither x `shouldReturn` (Just y)+testDecodeAgainst x y = decodeFileThrow x `shouldReturn` Just y main :: IO ()-main = hspec $ around_ in_mock_definitions_v9 $ do-- describe "Baserock.Schema.V9" $ do+main = hspec $ in_mock_definitions_v9 $ describe "Baserock.Schema.V9" $ do describe "ChunkInstructions" $ do- it "decodes correctly" $ do- "quux/strata/grilled-essential/brie-cc.morph" `testDecodeAgainst` v9_mock_chunk_instructions_brie_cc- "quux/strata/grilled-essential/linux-api-headers.morph" `testDecodeAgainst` v9_mock_chunk_instructions_linux_api_headers- "quux/strata/core/ccake.morph" `testDecodeAgainst` v9_mock_chunk_instructions_ccake- "quux/strata/core/sesame-sed.morph" `testDecodeAgainst` v9_mock_chunk_instructions_sesame_sed- it "encodes correctly" $ do- BS.readFile "quux/strata/grilled-essential/brie-cc.morph" `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_brie_cc- BS.readFile "quux/strata/grilled-essential/linux-api-headers.morph" `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_linux_api_headers- BS.readFile "quux/strata/core/ccake.morph" `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_ccake- BS.readFile "quux/strata/core/sesame-sed.morph" `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_sesame_sed+ it "decodes correctly" $ do+ "quux/strata/grilled-essential/brie-cc.morph"+ `testDecodeAgainst` v9_mock_chunk_instructions_brie_cc+ "quux/strata/grilled-essential/linux-api-headers.morph"+ `testDecodeAgainst` v9_mock_chunk_instructions_linux_api_headers+ "quux/strata/core/ccake.morph"+ `testDecodeAgainst` v9_mock_chunk_instructions_ccake+ "quux/strata/core/sesame-sed.morph"+ `testDecodeAgainst` v9_mock_chunk_instructions_sesame_sed+ it "encodes correctly" $ do+ BS.readFile "quux/strata/grilled-essential/brie-cc.morph"+ `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_brie_cc+ BS.readFile "quux/strata/grilled-essential/linux-api-headers.morph"+ `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_linux_api_headers+ BS.readFile "quux/strata/core/ccake.morph"+ `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_ccake+ BS.readFile "quux/strata/core/sesame-sed.morph"+ `shouldReturn` toPrettyYaml v9_mock_chunk_instructions_sesame_sed describe "Stratum" $ do- it "decodes correctly" $ do- "quux/strata/grilled-essential.morph" `testDecodeAgainst` v9_mock_stratum_grilled_essential- "quux/strata/core.morph" `testDecodeAgainst` v9_mock_stratum_core- it "encodes correctly" $ do- BS.readFile "quux/strata/grilled-essential.morph" `shouldReturn` toPrettyYaml v9_mock_stratum_grilled_essential- BS.readFile "quux/strata/core.morph" `shouldReturn` toPrettyYaml v9_mock_stratum_core+ it "decodes correctly" $ do+ "quux/strata/grilled-essential.morph"+ `testDecodeAgainst` v9_mock_stratum_grilled_essential+ "quux/strata/core.morph" `testDecodeAgainst` v9_mock_stratum_core+ it "encodes correctly" $ do+ BS.readFile "quux/strata/grilled-essential.morph"+ `shouldReturn` toPrettyYaml v9_mock_stratum_grilled_essential+ BS.readFile "quux/strata/core.morph"+ `shouldReturn` toPrettyYaml v9_mock_stratum_core describe "System" $ do- it "decodes correctly" $ do- "quux/systems/quux-system-x86_32.morph" `testDecodeAgainst` v9_mock_system_quux- it "encodes correctly" $ do- BS.readFile "quux/systems/quux-system-x86_32.morph" `shouldReturn` toPrettyYaml v9_mock_system_quux-- describe "StratumAST" $ do- it "decodes correctly" $ do- either (error . show) id <$> decodeStratumAST "quux/strata/grilled-essential.morph" `shouldReturn` v9_mock_stratum_grilled_essential_ast- either (error . show) id <$> decodeStratumAST "quux/strata/core.morph" `shouldReturn` v9_mock_stratum_core_ast-- describe "SystemAST" $ do- it "decodes correctly" $ do- either (error . show) id <$> decodeSystemAST "quux/systems/quux-system-x86_32.morph" `shouldReturn` v9_mock_system_quux_ast+ it "decodes correctly"+ $ "quux/systems/quux-system-x86_32.morph"+ `testDecodeAgainst` v9_mock_system_quux+ it "encodes correctly"+ $ BS.readFile "quux/systems/quux-system-x86_32.morph"+ `shouldReturn` toPrettyYaml v9_mock_system_quux