diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for baserock-schema + +## 0.0.1.0 (PreAlpha) + +* Add Basic Chunk, Stratum and System parsing for baserock definitions V9 +* Add "AST" decoders/encoders +* Add Stratum Graph representation diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# baserock-schema + +Definitions schema for baserock system definitions. + +You can build with + + stack build + +You can test with + + stack test + +You can test the in-place sanitizer application by running + + stack install + +which will install the baserock executable. You may then sit in a definitions repository and run + + baserock sanitize diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +import Baserock.Schema.V9 +import Control.Exception +import Control.Monad (when) +import Control.Monad.Except +import Data.Char (toUpper) +import System.Environment (getArgs) +import System.Console.Docopt + +patterns :: Docopt +patterns = [docoptFile|USAGE.txt|] + +getArgOrExit = getArgOrExitWith patterns + +main = do + args <- parseArgsOrExit patterns =<< getArgs + + 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 diff --git a/baserock-schema.cabal b/baserock-schema.cabal new file mode 100644 --- /dev/null +++ b/baserock-schema.cabal @@ -0,0 +1,89 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d703d786e2948a040b066e97b869ecdbe9cd30726fb041dceebae186941d79d4 + +name: baserock-schema +version: 0.0.1.0 +description: Please see the README on GitHub at +author: Daniel Firth +maintainer: locallycompact@gmail.com +copyright: 2018 Daniel Firth +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +library + exposed-modules: + Baserock + Baserock.Schema.Utils + Baserock.Schema.V9 + other-modules: + Paths_baserock_schema + hs-source-dirs: + src + build-depends: + algebraic-graphs + , base >=4.7 && <5 + , bytestring + , docopt + , errors + , mtl + , profunctors + , text + , transformers + , turtle + , yaml + default-language: Haskell2010 + +executable baserock + main-is: Main.hs + other-modules: + Paths_baserock_schema + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + algebraic-graphs + , base >=4.7 && <5 + , baserock-schema + , bytestring + , docopt + , errors + , mtl + , profunctors + , text + , transformers + , turtle + , yaml + default-language: Haskell2010 + +test-suite earthquake-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_baserock_schema + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , algebraic-graphs + , base >=4.7 && <5 + , baserock-schema + , bytestring + , docopt + , errors + , hspec + , mtl + , profunctors + , text + , transformers + , turtle + , yaml + default-language: Haskell2010 diff --git a/src/Baserock.hs b/src/Baserock.hs new file mode 100644 --- /dev/null +++ b/src/Baserock.hs @@ -0,0 +1,3 @@ +module Baserock where + +import Baserock.Schema.V9 diff --git a/src/Baserock/Schema/Utils.hs b/src/Baserock/Schema/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Baserock/Schema/Utils.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Baserock.Schema.Utils where + +import Control.Applicative +import Data.List +import Data.Maybe +import Data.Yaml + +listElemCmp as x y = fromJust $ liftA2 compare (elemIndex x as) (elemIndex y as) + +possibly f v = if v == mempty then mempty else [f .= v] diff --git a/src/Baserock/Schema/V9.hs b/src/Baserock/Schema/V9.hs new file mode 100644 --- /dev/null +++ b/src/Baserock/Schema/V9.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Baserock.Schema.V9 where + +import Algebra.Graph +import Baserock.Schema.Utils +import Control.Arrow +import Control.Error.Safe +import Control.Error.Util +import Control.Monad +import Control.Monad.Except +import qualified Data.ByteString as BS +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Profunctor +import Data.Text (Text, unpack) +import Data.Yaml +import Data.Yaml.Pretty +import GHC.Generics + +--- ChunkInstructions ("chunk.morph") + +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, Generic, Show) + +instance FromJSON ChunkInstructions where + parseJSON = withObject "ChunkInstructions" $ \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" .!= [] + +chunkInstructionsFieldOrder :: [Text] = + ["name", "kind", "build-system"] + <> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x] + <> ["rpm-metadata"] +chunkInstructionsFieldCmp = listElemCmp chunkInstructionsFieldOrder + +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) + +encodePrettyChunkInstructions = encodePretty $ setConfCompare chunkInstructionsFieldCmp defConfig + +-- 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, Generic, Show) + +instance FromJSON Chunk where + parseJSON = withObject "Chunk" $ \v -> Chunk + <$> v .: "name" + <*> v .:? "morph" + <*> v .: "repo" + <*> v .: "ref" + <*> v .:? "sha" + <*> v .:? "build-mode" .!= "staging" + <*> v .:? "build-system" .!= "manual" + <*> v .:? "build-depends" .!= [] + +chunkFieldOrder :: [Text] = ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"] +chunkFieldCmp = listElemCmp chunkFieldOrder + +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) + +encodePrettyChunk = encodePretty $ setConfCompare chunkFieldCmp defConfig + +data StratumBD = StratumBD { + stratumBDMorph :: Text +} deriving (Eq, Generic, Show) + +instance FromJSON StratumBD where + parseJSON = withObject "StratumBD" $ \v -> StratumBD + <$> v .: "morph" + +instance ToJSON StratumBD where + toJSON x = object ["morph" .= stratumBDMorph x] + +data Stratum = Stratum { + stratumName :: Text, + stratumDescription :: Maybe Text, + stratumBDs :: [StratumBD], + chunks :: [Chunk] +} deriving (Eq, Generic, Show) + +instance FromJSON Stratum where + parseJSON = withObject "Stratum" $ \v -> Stratum + <$> v .: "name" + <*> v .:? "description" + <*> v .:? "build-depends" .!= [] + <*> v .: "chunks" + +stratumFieldOrder :: [Text] = chunkFieldOrder ++ ["kind", "chunks"] +stratumFieldCmp = listElemCmp stratumFieldOrder + +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) + +encodePrettyStratum = encodePretty $ setConfCompare stratumFieldCmp defConfig + +-- System ("system.morph") + +data StratumInclude = StratumInclude { + stratumIncludeName :: Text, + stratumIncludeMorph :: Text +} deriving (Eq, Generic, Show) + +instance FromJSON StratumInclude where + parseJSON = withObject "StratumInclude" $ \v -> StratumInclude + <$> v .: "name" + <*> v .: "morph" + +stratumIncludeFieldOrder :: [Text] = ["name", "morph"] +stratumIncludeFieldCmp = listElemCmp stratumIncludeFieldOrder + +instance ToJSON StratumInclude where + toJSON x = object ["name" .= stratumIncludeName x, "morph" .= stratumIncludeMorph x] + +encodePrettyStratumInclude = encodePretty $ setConfCompare stratumIncludeFieldCmp defConfig + +data System = System { + systemName :: Text, + systemDescription :: Maybe Text, + arch :: Text, + strata :: [StratumInclude], + configurationExtensions :: [Text] +} deriving (Eq, Generic, Show) + +instance FromJSON System where + parseJSON = withObject "System" $ \v -> System + <$> v .: "name" + <*> v .:? "description" + <*> v .: "arch" + <*> v .: "strata" + <*> v .: "configuration-extensions" + +systemFieldOrder :: [Text] = stratumIncludeFieldOrder ++ ["kind", "description", "arch", "strata", "configuration-extensions"] +systemFieldCmp = listElemCmp systemFieldOrder + +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) + +encodePrettySystem = encodePretty $ setConfCompare systemFieldCmp defConfig + +--- 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 f (x, as) = do + BS.writeFile f (encodePrettyStratum x) + forM_ as $ \(i, j) -> BS.writeFile i (encodePrettyChunkInstructions j) + +encodeSystemAST f (x, as) = do + BS.writeFile f (encodePrettySystem x) + forM_ as $ \(i, j) -> encodeStratumAST i j + +-- 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. diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,169 @@ +{-# 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 + +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_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_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_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_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)]) + +in_mock_definitions_v9 = bracket_ (cd "test/mock-definitions-v9") (cd "../../") + +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) + it "encodes correctly" $ do + BS.readFile "quux/strata/grilled-essential/brie-cc.morph" `shouldReturn` encodePrettyChunkInstructions v9_mock_chunk_instructions_brie_cc + BS.readFile "quux/strata/grilled-essential/linux-api-headers.morph" `shouldReturn` encodePrettyChunkInstructions v9_mock_chunk_instructions_linux_api_headers + BS.readFile "quux/strata/core/ccake.morph" `shouldReturn` encodePrettyChunkInstructions v9_mock_chunk_instructions_ccake + BS.readFile "quux/strata/core/sesame-sed.morph" `shouldReturn` encodePrettyChunkInstructions v9_mock_chunk_instructions_sesame_sed + + 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) + it "encodes correctly" $ do + BS.readFile "quux/strata/grilled-essential.morph" `shouldReturn` (encodePrettyStratum v9_mock_stratum_grilled_essential) + BS.readFile "quux/strata/core.morph" `shouldReturn` (encodePrettyStratum 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) + it "encodes correctly" $ do + BS.readFile "quux/systems/quux-system-x86_32.morph" `shouldReturn` (encodePrettySystem 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