diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2018 +Copyright Daniel Firth (c) 2018 All rights reserved. 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: d703d786e2948a040b066e97b869ecdbe9cd30726fb041dceebae186941d79d4 +-- hash: 9b4d56a60e06088275634fa7f937c8cdec9c68ffb0e17ecb1285e5a6ab79f24a name: baserock-schema -version: 0.0.1.0 +version: 0.0.1.1 description: Please see the README on GitHub at 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 diff --git a/src/Baserock/Schema/Utils.hs b/src/Baserock/Schema/Utils.hs deleted file mode 100644 --- a/src/Baserock/Schema/Utils.hs +++ /dev/null @@ -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] 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,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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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