diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for baserock-schema +## 0.0.1.5 (PreAlpha) + +* Fix some schema issues. +* Add lens interfaces. +* Add example application using gitlab-api + ## 0.0.1.0 (PreAlpha) * Add Basic Chunk, Stratum and System parsing for baserock definitions V9 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,21 +1,44 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 System.Environment (getArgs) +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 patterns :: Docopt patterns = [docopt| Usage: + baserock bump-shas baserock sanitize |] getArgOrExit = getArgOrExitWith patterns +chunkLatest :: MonadGitlab m => Chunk -> m GitlabCommitData +chunkLatest = liftM2 getShaOfRef (toSignificantSuffix . _repo) _ref + +bumpChunkSha :: MonadGitlab m => Chunk -> m Chunk +bumpChunkSha c = fmap (flip (sha ?~) c . commitId) . chunkLatest $ c + +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 + +toSignificantSuffix = (!! 1) . Text.splitOn ":" + main = do args <- parseArgsOrExit patterns =<< getArgs @@ -25,3 +48,18 @@ case s of Right r -> encodeSystemAST f r Left e -> throwIO e + + when (args `isPresent` command "bump-shas") $ do + f <- args `getArgOrExit` (argument "stratum") + envPrivateToken <- getEnv "GITLAB_PRIVATE_TOKEN" + envBaseUrl <- getEnv "GITLAB_BASE_URL" + + aliases <- getAliases "ybd.conf" + + let gconf = GitlabConfig { glCredsUrl = BS8.pack envBaseUrl, glCredsToken = BS8.pack 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) 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: b6837e1fe21d79c10d9853821740047ab7d4a15eaee1668f814cb447afee0f08 +-- hash: c8c8db858030e83a98af816533ab7595e6c4e6052ce82f2a8c9baaa249dac1af name: baserock-schema -version: 0.0.1.3 +version: 0.0.1.5 synopsis: Baserock Definitions Schema description: Baserock Definitions Schema - Parsers, Printers, Encoders, Decoders, ASTs, Graphs and Traversals category: Data @@ -37,10 +37,12 @@ , base >=4.7 && <5 , bytestring , errors + , lens , mtl , text , transformers , turtle + , unordered-containers , yaml default-language: Haskell2010 @@ -58,10 +60,13 @@ , bytestring , docopt , errors + , gitlab-api + , lens , mtl , text , transformers , turtle + , unordered-containers , yaml default-language: Haskell2010 @@ -81,9 +86,11 @@ , bytestring , errors , hspec + , lens , mtl , text , transformers , turtle + , unordered-containers , yaml default-language: Haskell2010 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,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | @@ -14,24 +15,65 @@ module Baserock.Schema.V9 ( -- * Schema - ChunkInstructions (..), - Chunk (..), - Stratum (..), - StratumBD (..), - StratumInclude (..), - System (..), + 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, - decodeStratumAST, + -- * Codecs + encodeStratumAST, - decodeSystemAST, + decodeStratumAST, encodeSystemAST, + decodeSystemAST, - -- * toPrettyYaml + -- * Misc + + encodeFilePretty, ToPrettyYaml(..) ) where @@ -41,9 +83,11 @@ 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 @@ -51,9 +95,9 @@ import Data.Yaml import Data.Yaml.Pretty -listElemCmp as x y = fromJust $ liftA2 compare (elemIndex x as) (elemIndex y as) +listElemCmp as x y = fromMaybe LT $ liftA2 compare (elemIndex x as) (elemIndex y as) -possibly f v = if v == mempty then mempty else [f .= v] +possibly f v = if v == mzero then mzero else [f .= v] class ToJSON a => ToPrettyYaml a where fieldOrder :: a -> [Text] @@ -64,24 +108,29 @@ toPrettyYaml :: a -> BS.ByteString toPrettyYaml x = encodePretty (setConfCompare (fieldCmp x) defConfig) x ---- ChunkInstructions ("chunk.morph") --- +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] + _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 = withObject "ChunkInstructions" $ \v -> ChunkInstructions + parseJSON (Object v) = ChunkInstructions <$> v .: "name" <*> v .:? "build-system" .!= "manual" <*> v .:? "pre-configure-commands" .!= [] @@ -96,16 +145,16 @@ 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) + 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"] @@ -116,18 +165,20 @@ -- Stratum ("stratum.morph") data Chunk = Chunk { - chunkName :: Text, - chunkMorph :: Maybe Text, - repo :: Text, - ref :: Text, - sha :: Maybe Text, - buildMode :: Text, - chunkBuildSystem :: Text, - chunkBDs :: [Text] + _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 = withObject "Chunk" $ \v -> Chunk + parseJSON (Object v) = Chunk <$> v .: "name" <*> v .:? "morph" <*> v .: "repo" @@ -138,76 +189,87 @@ <*> 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) - <> possibly "build-mode" (buildMode x) - <> possibly "build-system" (chunkBuildSystem x) - <> possibly "build-depends" (chunkBDs x) + 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 + _stratumBDMorph :: Text } deriving (Eq, Show) +$(makeLenses ''StratumBD) + instance FromJSON StratumBD where - parseJSON = withObject "StratumBD" $ \v -> StratumBD + parseJSON (Object v) = StratumBD <$> v .: "morph" instance ToJSON StratumBD where - toJSON x = object ["morph" .= stratumBDMorph x] + 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] + _stratumName :: Text, + _stratumDescription :: Maybe Text, + _stratumBDs :: [StratumBD], + _chunks :: [Chunk] } deriving (Eq, Show) +$(makeLenses ''Stratum) + instance FromJSON Stratum where - parseJSON = withObject "Stratum" $ \v -> Stratum + 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) + 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", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"] + 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 + _stratumIncludeName :: Text, + _stratumIncludeMorph :: Text } deriving (Eq, Show) +$(makeLenses ''StratumInclude) + instance FromJSON StratumInclude where - parseJSON = withObject "StratumInclude" $ \v -> StratumInclude + parseJSON (Object v) = StratumInclude <$> v .: "name" <*> v .: "morph" instance ToJSON StratumInclude where - toJSON x = object ["name" .= stratumIncludeName x, "morph" .= stratumIncludeMorph x] + 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] + _systemName :: Text, + _systemDescription :: Maybe Text, + _arch :: Text, + _strata :: [StratumInclude], + _configurationExtensions :: [Text] } deriving (Eq, Show) +$(makeLenses ''System) + instance FromJSON System where - parseJSON = withObject "System" $ \v -> System + parseJSON (Object v) = System <$> v .: "name" <*> v .:? "description" <*> v .: "arch" @@ -215,8 +277,8 @@ <*> 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) + 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"] @@ -232,22 +294,22 @@ (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) +decodeStratumAST = decodeASTWith (fmap unpack . mapMaybe _chunkMorph . _chunks) (ExceptT . decodeFileEither) decodeSystemAST :: FilePath -> IO (Either ParseException SystemAST) -decodeSystemAST = decodeASTWith (fmap (unpack . stratumIncludeMorph) . strata) (ExceptT . decodeStratumAST) +decodeSystemAST = decodeASTWith (fmap (unpack . _stratumIncludeMorph) . _strata) (ExceptT . decodeStratumAST) -- Encoders encodeStratumAST :: FilePath -> StratumAST -> IO () encodeStratumAST f (x, as) = do - BS.writeFile f (toPrettyYaml x) - forM_ as $ \(i, j) -> BS.writeFile i (toPrettyYaml j) + encodeFilePretty f x + forM_ as $ uncurry encodeFilePretty encodeSystemAST :: FilePath -> SystemAST -> IO () encodeSystemAST f (x, as) = do - BS.writeFile f (toPrettyYaml x) - forM_ as $ \(i, j) -> encodeStratumAST i j + encodeFilePretty f x + forM_ as $ uncurry encodeStratumAST -- Utility @@ -256,9 +318,9 @@ 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) + 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -10,110 +10,110 @@ import Turtle 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 = [] + _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 = [] + _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" ] } ]} + _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 = [] + _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 = [] + _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" ] } ]} + _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"]} + _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), @@ -129,16 +129,18 @@ in_mock_definitions_v9 = bracket_ (cd "test/mock-definitions-v9") (cd "../../") +testDecodeAgainst x y = either (error . show) id <$> decodeFileEither x `shouldReturn` (Just y) + main :: IO () main = hspec $ around_ in_mock_definitions_v9 $ do describe "Baserock.Schema.V9" $ do describe "ChunkInstructions" $ do it "decodes correctly" $ do - decodeFile "quux/strata/grilled-essential/brie-cc.morph" `shouldReturn` (Just v9_mock_chunk_instructions_brie_cc :: Maybe ChunkInstructions) - decodeFile "quux/strata/grilled-essential/linux-api-headers.morph" `shouldReturn` (Just v9_mock_chunk_instructions_linux_api_headers :: Maybe ChunkInstructions) - decodeFile "quux/strata/core/ccake.morph" `shouldReturn` (Just v9_mock_chunk_instructions_ccake :: Maybe ChunkInstructions) - decodeFile "quux/strata/core/sesame-sed.morph" `shouldReturn` (Just v9_mock_chunk_instructions_sesame_sed :: Maybe ChunkInstructions) + "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 @@ -147,15 +149,15 @@ describe "Stratum" $ do it "decodes correctly" $ do - decodeFile "quux/strata/grilled-essential.morph" `shouldReturn` (Just v9_mock_stratum_grilled_essential :: Maybe Stratum) - decodeFile "quux/strata/core.morph" `shouldReturn` (Just v9_mock_stratum_core :: Maybe Stratum) + "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 - decodeFile "quux/systems/quux-system-x86_32.morph" `shouldReturn` (Just v9_mock_system_quux :: Maybe System) + "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