{-# LANGUAGE OverloadedStrings #-}
module Baserock.Schema.V9 (
ChunkInstructions (..),
Chunk (..),
Stratum (..),
StratumBD (..),
StratumInclude (..),
System (..),
StratumAST,
SystemAST,
decodeStratumAST,
encodeStratumAST,
decodeSystemAST,
encodeSystemAST,
ToPrettyYaml(..)
) where
import Algebra.Graph
import Control.Arrow
import Control.Applicative
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.Text (Text, unpack)
import Data.Yaml
import Data.Yaml.Pretty
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
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, 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" .!= []
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)
instance ToPrettyYaml ChunkInstructions where
fieldOrder = const $ ["name", "kind", "build-system"]
<> fmap (<> "-commands") ["configure", "build", "install"] >>= \x -> ["pre-" <> x, x, "post-" <> x]
<> ["rpm-metadata"]
data Chunk = Chunk {
chunkName :: Text,
chunkMorph :: Maybe Text,
repo :: Text,
ref :: Text,
sha :: Maybe Text,
buildMode :: Text,
chunkBuildSystem :: Text,
chunkBDs :: [Text]
} deriving (Eq, 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" .!= []
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)
instance ToPrettyYaml Chunk where
fieldOrder = const ["name", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends"]
data StratumBD = StratumBD {
stratumBDMorph :: Text
} deriving (Eq, 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, Show)
instance FromJSON Stratum where
parseJSON = withObject "Stratum" $ \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)
instance ToPrettyYaml Stratum where
fieldOrder = const ["name", "kind", "morph", "repo", "ref", "sha", "build-mode", "build-system", "build-depends", "chunks"]
data StratumInclude = StratumInclude {
stratumIncludeName :: Text,
stratumIncludeMorph :: Text
} deriving (Eq, Show)
instance FromJSON StratumInclude where
parseJSON = withObject "StratumInclude" $ \v -> StratumInclude
<$> v .: "name"
<*> v .: "morph"
instance ToJSON StratumInclude where
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]
} deriving (Eq, Show)
instance FromJSON System where
parseJSON = withObject "System" $ \v -> System
<$> v .: "name"
<*> v .:? "description"
<*> v .: "arch"
<*> v .: "strata"
<*> 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)
instance ToPrettyYaml System where
fieldOrder = const $ ["name", "morph", "kind", "description", "arch", "strata", "configuration-extensions"]
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)
encodeStratumAST :: FilePath -> StratumAST -> IO ()
encodeStratumAST f (x, as) = do
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 (toPrettyYaml x)
forM_ as $ \(i, j) -> encodeStratumAST i j
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)