baserock-schema 0.0.1.0 → 0.0.1.1
raw patch · 5 files changed
+85/−66 lines, 5 files
Files
- LICENSE +1/−1
- baserock-schema.cabal +2/−3
- src/Baserock/Schema/Utils.hs +0/−12
- src/Baserock/Schema/V9.hs +75/−43
- test/Spec.hs +7/−7
LICENSE view
@@ -1,4 +1,4 @@-Copyright Author name here (c) 2018+Copyright Daniel Firth (c) 2018 All rights reserved.
baserock-schema.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d703d786e2948a040b066e97b869ecdbe9cd30726fb041dceebae186941d79d4+-- hash: 9b4d56a60e06088275634fa7f937c8cdec9c68ffb0e17ecb1285e5a6ab79f24a name: baserock-schema-version: 0.0.1.0+version: 0.0.1.1 description: Please see the README on GitHub at <https://gitlab.com/locallycompact/baserock-schema#readme> author: Daniel Firth maintainer: locallycompact@gmail.com@@ -21,7 +21,6 @@ library exposed-modules: Baserock- Baserock.Schema.Utils Baserock.Schema.V9 other-modules: Paths_baserock_schema
− src/Baserock/Schema/Utils.hs
@@ -1,12 +0,0 @@-{-# 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
@@ -1,15 +1,44 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-} -module Baserock.Schema.V9 where+-----------------------------------------------------------------------------+-- |+-- Module : Baserock.Schema.V9+-- 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 ( + -- * Schema+ ChunkInstructions (..),+ Chunk (..),+ Stratum (..),+ StratumBD (..),+ StratumInclude (..),+ System (..),++ -- * ASTs+ + StratumAST,+ SystemAST,++ decodeStratumAST,+ encodeStratumAST,+ decodeSystemAST,+ encodeSystemAST,++ -- * toPrettyYaml+ ToPrettyYaml(..)++) where+ import Algebra.Graph-import Baserock.Schema.Utils import Control.Arrow+import Control.Applicative import Control.Error.Safe import Control.Error.Util import Control.Monad@@ -18,14 +47,25 @@ 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")+listElemCmp as x y = fromJust $ liftA2 compare (elemIndex x as) (elemIndex y as) +possibly f v = if v == mempty then mempty 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++--- ChunkInstructions ("chunk.morph")+-- data ChunkInstructions = ChunkInstructions { chunkInstructionsName :: Text, buildSystem :: Text,@@ -38,7 +78,7 @@ preInstallCommands :: [Text], installCommands :: [Text], postInstallCommands :: [Text]-} deriving (Eq, Generic, Show)+} deriving (Eq, Show) instance FromJSON ChunkInstructions where parseJSON = withObject "ChunkInstructions" $ \v -> ChunkInstructions@@ -54,12 +94,6 @@ <*> 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]@@ -73,8 +107,12 @@ <> possibly "install-commands" (installCommands x) <> possibly "post-install-commands" (postInstallCommands x) -encodePrettyChunkInstructions = encodePretty $ setConfCompare chunkInstructionsFieldCmp defConfig +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 {@@ -86,7 +124,7 @@ buildMode :: Text, chunkBuildSystem :: Text, chunkBDs :: [Text]-} deriving (Eq, Generic, Show)+} deriving (Eq, Show) instance FromJSON Chunk where parseJSON = withObject "Chunk" $ \v -> Chunk@@ -99,9 +137,6 @@ <*> 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)@@ -109,11 +144,12 @@ <> possibly "build-system" (chunkBuildSystem x) <> possibly "build-depends" (chunkBDs x) -encodePrettyChunk = encodePretty $ setConfCompare chunkFieldCmp defConfig+instance ToPrettyYaml Chunk where+ fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"] data StratumBD = StratumBD { stratumBDMorph :: Text-} deriving (Eq, Generic, Show)+} deriving (Eq, Show) instance FromJSON StratumBD where parseJSON = withObject "StratumBD" $ \v -> StratumBD@@ -127,7 +163,7 @@ stratumDescription :: Maybe Text, stratumBDs :: [StratumBD], chunks :: [Chunk]-} deriving (Eq, Generic, Show)+} deriving (Eq, Show) instance FromJSON Stratum where parseJSON = withObject "Stratum" $ \v -> Stratum@@ -136,35 +172,31 @@ <*> 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+instance ToPrettyYaml Stratum where+ fieldOrder = const ["name", "kind", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"] -- System ("system.morph") data StratumInclude = StratumInclude { stratumIncludeName :: Text, stratumIncludeMorph :: Text-} deriving (Eq, Generic, Show)+} deriving (Eq, 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+instance ToPrettyYaml StratumInclude where+ fieldOrder = const ["name", "morph"] data System = System { systemName :: Text,@@ -172,7 +204,7 @@ arch :: Text, strata :: [StratumInclude], configurationExtensions :: [Text]-} deriving (Eq, Generic, Show)+} deriving (Eq, Show) instance FromJSON System where parseJSON = withObject "System" $ \v -> System@@ -182,14 +214,12 @@ <*> 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+instance ToPrettyYaml System where+ fieldOrder = const $ ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"] --- Decoders @@ -209,12 +239,14 @@ -- Encoders +encodeStratumAST :: FilePath -> StratumAST -> IO () encodeStratumAST f (x, as) = do- BS.writeFile f (encodePrettyStratum x)- forM_ as $ \(i, j) -> BS.writeFile i (encodePrettyChunkInstructions j)+ BS.writeFile f (toPrettyYaml x)+ forM_ as $ \(i, j) -> BS.writeFile i (toPrettyYaml j) +encodeSystemAST :: FilePath -> SystemAST -> IO () encodeSystemAST f (x, as) = do- BS.writeFile f (encodePrettySystem x)+ BS.writeFile f (toPrettyYaml x) forM_ as $ \(i, j) -> encodeStratumAST i j -- Utility
test/Spec.hs view
@@ -140,24 +140,24 @@ 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+ 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 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)+ 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) it "encodes correctly" $ do- BS.readFile "quux/systems/quux-system-x86_32.morph" `shouldReturn` (encodePrettySystem v9_mock_system_quux)+ BS.readFile "quux/systems/quux-system-x86_32.morph" `shouldReturn` toPrettyYaml v9_mock_system_quux describe "StratumAST" $ do it "decodes correctly" $ do