packages feed

baserock-schema (empty) → 0.0.1.0

raw patch · 10 files changed

+588/−0 lines, 10 filesdep +QuickCheckdep +algebraic-graphsdep +basesetup-changed

Dependencies added: QuickCheck, algebraic-graphs, base, baserock-schema, bytestring, docopt, errors, hspec, mtl, profunctors, text, transformers, turtle, yaml

Files

+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <path/to/system.morph>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ baserock-schema.cabal view
@@ -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 <https://gitlab.com/locallycompact/baserock-schema#readme>+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
+ src/Baserock.hs view
@@ -0,0 +1,3 @@+module Baserock where++import Baserock.Schema.V9
+ src/Baserock/Schema/Utils.hs view
@@ -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]
+ src/Baserock/Schema/V9.hs view
@@ -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.
+ test/Spec.hs view
@@ -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