diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,5 +1,5 @@ name: b9 -version: 0.5.13 +version: 0.5.14 synopsis: A tool and library for building virtual machine images. @@ -82,6 +82,7 @@ , B9.Content.Generator , B9.Content.StringTemplate , B9.QCUtil + , B9.DSL other-modules: Paths_b9 -- other-extensions: build-depends: ConfigFile @@ -95,8 +96,10 @@ , conduit-extra , directory , filepath + , hashable , mtl , time >= 1.5.0 && < 2 + , parallel , parsec , pretty-show , pretty @@ -116,14 +119,22 @@ default-extensions: TupleSections , GeneralizedNewtypeDeriving , DeriveDataTypeable + , DeriveGeneric , RankNTypes , FlexibleContexts , GADTs + , DataKinds + , KindSignatures + , TypeFamilies + , DeriveFunctor + , TemplateHaskell + , StandaloneDeriving + , CPP hs-source-dirs: src/lib default-language: Haskell2010 - ghc-options: -with-rtsopts=-N -Wall -fno-warn-unused-imports + ghc-options: -with-rtsopts=-N -Wall -fwarn-unused-binds -fno-warn-unused-do-bind - if impl(ghc >= 7.8.2) && impl(ghc < 7.10) + if impl(ghc >= 7.8.2) && impl(ghc <= 7.10) ghc-options: -fno-warn-amp executable b9c @@ -137,9 +148,21 @@ , optparse-applicative hs-source-dirs: src/cli default-language: Haskell2010 - ghc-options: -threaded -with-rtsopts=-N -Wall -fno-warn-unused-imports + default-extensions: TupleSections + , GeneralizedNewtypeDeriving + , DeriveDataTypeable + , RankNTypes + , FlexibleContexts + , GADTs + , DataKinds + , KindSignatures + , TypeFamilies + , DeriveFunctor + , TemplateHaskell + , CPP + ghc-options: -threaded -with-rtsopts=-N -Wall -fwarn-unused-binds -fno-warn-unused-do-bind - if impl(ghc >= 7.8.2) && impl(ghc < 7.10) + if impl(ghc >= 7.8.2) && impl(ghc <= 7.10) ghc-options: -fno-warn-amp test-suite spec @@ -165,5 +188,17 @@ , bytestring , text , semigroups - if impl(ghc >= 7.8.2) && impl(ghc < 7.10) - ghc-options: -fno-warn-amp + default-extensions: TupleSections + , GeneralizedNewtypeDeriving + , DeriveDataTypeable + , RankNTypes + , FlexibleContexts + , GADTs + , DataKinds + , KindSignatures + , TypeFamilies + , DeriveFunctor + , TemplateHaskell + , CPP + if impl(ghc >= 7.8.2) && impl(ghc <= 7.10) + ghc-options: -fno-warn-amp -fno-warn-unused-do-bind diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -9,10 +9,12 @@ import Data.Maybe import Data.Version import Paths_b9 -import Prelude hiding (catch) import System.Directory +import System.IO.Error hiding (isDoesNotExistErrorType) +#if !MIN_VERSION_base(4,8,0) import System.IO.Error hiding (catch) - +import Prelude hiding (catch) +#endif import B9 main :: IO () @@ -30,15 +32,7 @@ (helper <*> (B9Options <$> globals <*> cmds <*> buildVars)) (fullDesc <> progDesc - "Build and run VM-Images inside LXC containers.\ - \ Custom arguments follow after '--' and are\ - \ accessable in many strings in build files \ - \ trough shell like variable references, i.e. \ - \'${arg_N}' referes to positional argument $N.\n\ - \\n\ - \Repository names passed to the command line are\ - \ looked up in the B9 configuration file, which is\ - \ per default located in: '~/.b9/b9.conf'" <> + "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'" <> headerDoc (Just helpHeader))) where helpHeader = @@ -100,8 +94,7 @@ (if not (isJust (repository conf')) then do errorL - "No repository specified! \ - \ Use '-r' to specify a repo BEFORE 'push'." + "No repository specified! Use '-r' to specify a repo BEFORE 'push'." return False else do pushSharedImageLatestVersion name @@ -239,9 +232,7 @@ Left er -> error (printf - "Failed to add remote repo '%s'\ - \ to b9 configuration. The \ - \error was: \"%s\"." + "Failed to add remote repo '%s' to b9 configuration. The error was: \"%s\"." (show repo) (show er)) Right cpWithRepo -> writeB9Config cfgFile cpWithRepo @@ -342,54 +333,37 @@ "build" (info (runBuildArtifacts <$> buildFileParser) - (progDesc - "Merge all build file and\ - \ generate all artifacts.")) <> + (progDesc "Merge all build file and generate all artifacts.")) <> command "run" (info (runRun <$> sharedImageNameParser <*> many (strArgument idm)) (progDesc - "Run a command on the lastest version of the\ - \ specified shared image. All modifications\ - \ are lost on exit.")) <> + "Run a command on the lastest version of the specified shared image. All modifications are lost on exit.")) <> command "push" (info (runPush <$> sharedImageNameParser) (progDesc - "Push the lastest shared image\ - \ from cache to the selected \ - \ remote repository.")) <> + "Push the lastest shared image from cache to the selected remote repository.")) <> command "pull" (info (runPull <$> optional sharedImageNameParser) (progDesc - "Either pull shared image meta\ - \ data from all repositories,\ - \ or only from just a selected one.\ - \ If additionally the name of a\ - \ shared images was specified,\ - \ pull the newest version\ - \ from either the selected repo,\ - \ or from the repo with the most\ - \ recent version.")) <> + "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version.")) <> command "clean-local" (info (pure runGcLocalRepoCache) (progDesc - "Remove old versions of shared images\ - \ from the local cache.")) <> + "Remove old versions of shared images from the local cache.")) <> command "clean-remote" (info (pure runGcRemoteRepoCache) (progDesc - "Remove cached meta-data of a remote repository. \ - \If no '-r' is given, clean the meta data of ALL \ - \remote repositories.")) <> + "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories.")) <> command "list" (info (pure runListSharedImages) (progDesc "List shared images.")) <> @@ -410,8 +384,7 @@ some (strOption (help - "Build file to load, specify multiple build\ - \ files (each witch '-f') to build them all in a single run." <> + "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <> short 'f' <> long "project-file" <> metavar "FILENAME" <> @@ -432,9 +405,7 @@ (SshPrivKey <$> strArgument (help - "Path to the SSH private\ - \ key file used for \ - \ authorization." <> + "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE")) <*> (SshRemoteHost <$> ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*> diff --git a/src/lib/B9/ArtifactGenerator.hs b/src/lib/B9/ArtifactGenerator.hs --- a/src/lib/B9/ArtifactGenerator.hs +++ b/src/lib/B9/ArtifactGenerator.hs @@ -10,10 +10,15 @@ getAssemblyOutputFiles) where - +import Control.Parallel.Strategies +import Data.Binary import Data.Data +import Data.Hashable +import GHC.Generics (Generic) +#if !MIN_VERSION_base(4,8,0) import Data.Monoid import Control.Applicative +#endif import System.FilePath ((<.>), ()) import B9.DiskImages @@ -115,8 +120,12 @@ -- that is a unique, human readable string describing the -- artifact to assemble. EmptyArtifact - deriving (Read,Show,Eq,Data,Typeable) + deriving (Read,Show,Eq,Data,Typeable,Generic) +instance Hashable ArtifactGenerator +instance Binary ArtifactGenerator +instance NFData ArtifactGenerator + instance Monoid ArtifactGenerator where mempty = Let [] [] (Let [] []) `mappend` x = x @@ -158,13 +167,17 @@ -- ^ __Deprecated__ Concatenate the files generated by the -- nested 'ArtifactSource's. The nested, generated files -- are not written when they are concatenated. - deriving (Read,Show,Eq,Data,Typeable) + deriving (Read,Show,Eq,Data,Typeable,Generic) +instance Hashable ArtifactSource +instance Binary ArtifactSource +instance NFData ArtifactSource + -- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all -- instances IDs are unique. newtype InstanceId = IID String - deriving (Read,Show,Typeable,Data,Eq) + deriving (Read,Show,Typeable,Data,Eq,NFData,Binary,Hashable) -- | The variable containing the instance id. __Deprecated__ instanceIdKey :: String @@ -198,8 +211,12 @@ VmScript -- ^ a set of VM-images that were created by executing a -- build script on them. - deriving (Read,Show,Typeable,Data,Eq) + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable ArtifactAssembly +instance Binary ArtifactAssembly +instance NFData ArtifactAssembly + -- | A type representing the targets assembled by -- 'B9.ArtifactGeneratorImpl.assemble' from an 'ArtifactAssembly'. There is a -- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce upto @@ -207,20 +224,32 @@ data AssembledArtifact = AssembledArtifact InstanceId [ArtifactTarget] - deriving (Read,Show,Typeable,Data,Eq) + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable AssembledArtifact +instance Binary AssembledArtifact +instance NFData AssembledArtifact + data ArtifactTarget = CloudInitTarget CloudInitType FilePath | VmImagesTarget - deriving (Read,Show,Typeable,Data,Eq) + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable ArtifactTarget +instance Binary ArtifactTarget +instance NFData ArtifactTarget + data CloudInitType = CI_ISO | CI_VFAT | CI_DIR - deriving (Read,Show,Typeable,Data,Eq) + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable CloudInitType +instance Binary CloudInitType +instance NFData CloudInitType + -- | Return the files that the artifact assembly consist of. getAssemblyOutputFiles :: ArtifactAssembly -> [FilePath] getAssemblyOutputFiles (VmImages ts _) = @@ -233,6 +262,8 @@ | t == CI_VFAT = [baseName <.> "vfat"] | t == CI_DIR = [baseName "meta-data", baseName "user-data"] | otherwise = [] + + -- * QuickCheck instances instance Arbitrary ArtifactGenerator where diff --git a/src/lib/B9/ArtifactGeneratorImpl.hs b/src/lib/B9/ArtifactGeneratorImpl.hs --- a/src/lib/B9/ArtifactGeneratorImpl.hs +++ b/src/lib/B9/ArtifactGeneratorImpl.hs @@ -124,10 +124,7 @@ then return (zip vars <$> valueSets) else cgError (printf - "Error in 'Each' binding during artifact \ - \generation in:\n '%s'.\n\nThe variable list\n\ - \%s\n has %i entries, but this binding set\n%s\n\n\ - \has a different number of entries!\n" + "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n" (ppShow g) (ppShow vars) (length vars) @@ -137,18 +134,17 @@ -> [(String, [String])] -> CGParser [[(String, String)]] eachBindingSet g kvs = do - checkInput - return bindingSets - + checkInput + return bindingSets where - bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs] - checkInput = when (1 /= length (nub $ length . snd <$> kvs)) - (cgError - (printf - "Error in 'Each' binding: \n%s\n\ - \All value lists must have the same\ - \length!" - (ppShow g))) + bindingSets = transpose [repeat k `zip` vs | (k,vs) <- kvs] + checkInput = + when + (1 /= length (nub $ length . snd <$> kvs)) + (cgError + (printf + "Error in 'Each' binding: \n%s\nAll value lists must have the same length!" + (ppShow g))) writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser () @@ -185,7 +181,6 @@ execIGEnv :: InstanceGenerator CGEnv -> Either String (InstanceGenerator [SourceGenerator]) execIGEnv (IG iid (CGEnv env sources) assembly) = IG iid <$> sourceGens <*> pure (substAssembly env assembly) - where sourceGens = join <$> mapM (toSourceGen env) sources @@ -365,15 +360,10 @@ let isoFile = outPath <.> "iso" tmpFile = buildDir takeFileName isoFile ensureDir tmpFile - dbgL (printf "creating cloud init iso temp image '%s',\ - \ destination file: '%s" tmpFile isoFile) + dbgL (printf "creating cloud init iso temp image '%s', destination file: '%s" tmpFile isoFile) cmd (printf - "genisoimage\ - \ -output '%s'\ - \ -volid cidata\ - \ -rock\ - \ -d '%s' 2>&1" + "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1" tmpFile instanceDir) dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile) diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs --- a/src/lib/B9/B9Config.hs +++ b/src/lib/B9/B9Config.hs @@ -16,7 +16,6 @@ , BuildVariables ) where -import Data.Monoid import Data.Maybe (fromMaybe) import Control.Monad import Control.Exception @@ -24,7 +23,10 @@ import Control.Monad.IO.Class import System.Directory import Text.Printf +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif +import Data.Monoid import B9.ConfigUtils diff --git a/src/lib/B9/Builder.hs b/src/lib/B9/Builder.hs --- a/src/lib/B9/Builder.hs +++ b/src/lib/B9/Builder.hs @@ -30,28 +30,6 @@ import Control.Monad.IO.Class import System.Directory -import B9.B9Monad -import B9.ConfigUtils -import B9.B9Config -import B9.ExecEnv -import B9.DiskImages -import B9.DiskImageBuilder -import B9.ShellScript -import B9.Repository -import B9.RepositoryIO -import B9.ArtifactGenerator -import B9.ArtifactGeneratorImpl -import B9.Vm -import B9.VmBuilder -import B9.QCUtil - -import B9.Content.AST -import B9.Content.StringTemplate -import B9.Content.ErlTerms -import B9.Content.ErlangPropList -import B9.Content.YamlObject -import B9.Content.Generator - buildArtifacts :: ArtifactGenerator -> ConfigParser -> B9Config -> IO Bool buildArtifacts artifactGenerator cfgParser cliCfg = withB9Config cfgParser cliCfg $ \cfg -> diff --git a/src/lib/B9/ConfigUtils.hs b/src/lib/B9/ConfigUtils.hs --- a/src/lib/B9/ConfigUtils.hs +++ b/src/lib/B9/ConfigUtils.hs @@ -24,7 +24,9 @@ import Data.Monoid import Data.Function ( on ) import Data.Typeable +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.Exception import Control.Monad.IO.Class import System.Directory diff --git a/src/lib/B9/Content/AST.hs b/src/lib/B9/Content/AST.hs --- a/src/lib/B9/Content/AST.hs +++ b/src/lib/B9/Content/AST.hs @@ -22,83 +22,91 @@ , CanRender(..) ) where +import Control.Parallel.Strategies +import Data.Binary import qualified Data.ByteString as B -import Data.Semigroup -import Data.Data -import Control.Applicative -import Control.Monad.IO.Class -import Control.Monad.Reader +import Data.Data +import Data.Hashable +import Data.Semigroup +import GHC.Generics (Generic) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad.IO.Class +import Control.Monad.Reader -import B9.Content.StringTemplate +import B9.Content.StringTemplate -import Test.QuickCheck -import B9.QCUtil +import Test.QuickCheck +import B9.QCUtil -- | Types of values that can be parsed/rendered from/to 'ByteString's. This -- class is used as basis for the 'ASTish' class. -class (Semigroup a) => ConcatableSyntax a where - -- Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@ - decodeSyntax :: FilePath -- ^ An arbitrary string for error messages that corresponds - -- to a possible input file. - -> B.ByteString -- ^ The raw input to parse - -> Either String a - -- Generate a string representation of @a@ - encodeSyntax :: a -> B.ByteString +class (Semigroup a) => ConcatableSyntax a where + -- Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@ + decodeSyntax + :: FilePath -- ^ An arbitrary string for error messages that + -> B.ByteString -- ^ The raw input to parse + -> Either String a + -- Generate a string representation of @a@ + encodeSyntax + :: a -> B.ByteString instance ConcatableSyntax B.ByteString where - decodeSyntax _ = Right - encodeSyntax = id + decodeSyntax _ = Right + encodeSyntax = id -- | Describe how to create structured content that has a tree-like syntactic -- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines -- a /context/ into which the 'AST' is embeded, -- e.g. B9.Content.Generator.Content'. The second parameter defines a specifix -- syntax, e.g 'B9.Content.ErlangPropList' that the 'AST' value generates. -data AST c a = ASTObj [(String, AST c a)] -- ^ Create an object similar to a - -- Json object. - | ASTArr [AST c a] -- ^ An array. - | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very - -- powerful tool that allows to combine - -- several inputs in a smart and safe way, - -- e.g. by merging the values of the same - -- fields in yaml objects. - | ASTEmbed c -- Embed some pure content. - | ASTString String -- A string literal. - | ASTParse SourceFile -- An 'AST' obtained from parsing a source - -- file that contains a string corresponding - -- to the type parameter @a@, e.g. 'YamlObject's - | AST a -- Embed a literal @a@. - deriving (Read, Show, Typeable, Data, Eq) +data AST c a + = ASTObj [(String, AST c a)] -- ^ Create an object similar to a + -- Json object. + | ASTArr [AST c a] -- ^ An array. + | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very + -- powerful tool that allows to combine + | + -- several inputs in a smart and safe way, + -- e.g. by merging the values of the same + -- fields in yaml objects. + ASTEmbed c -- Embed some pure content. + | ASTString String -- A string literal. + | ASTParse SourceFile -- An 'AST' obtained from parsing a source + -- file that contains a string corresponding + | + -- to the type parameter @a@, e.g. 'YamlObject's + AST a -- Embed a literal @a@. + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance (Hashable c, Hashable a) => Hashable (AST c a) +instance (Binary c, Binary a) => Binary (AST c a) +instance (NFData c, NFData a) => NFData (AST c a) + + -- | Types of values that describe content, that can be created from an 'AST'. -class (ConcatableSyntax a) => ASTish a where - fromAST :: (CanRender c - ,Applicative m - ,Monad m - ,MonadIO m - ,MonadReader Environment m) - => AST c a - -> m a +class (ConcatableSyntax a) => ASTish a where + fromAST + :: (CanRender c, Applicative m, Monad m, MonadIO m, MonadReader Environment m) + => AST c a -> m a -- | Types of values that can be /rendered/ into a 'ByteString' -class CanRender c where - render :: (Functor m - ,Applicative m - ,MonadIO m - ,MonadReader Environment m) - => c - -> m B.ByteString +class CanRender c where + render + :: (Functor m, Applicative m, MonadIO m, MonadReader Environment m) + => c -> m B.ByteString instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where - arbitrary = oneof [ASTObj <$> smaller (listOf ((,) - <$> arbitrary - <*> arbitrary)) - ,ASTArr <$> smaller (listOf arbitrary) - ,ASTMerge <$> sized - (\s -> resize (max 2 s) - (listOf (halfSize arbitrary))) - ,ASTEmbed <$> smaller arbitrary - ,ASTString <$> arbitrary - ,ASTParse <$> smaller arbitrary - ,AST <$> smaller arbitrary - ] + arbitrary = + oneof + [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary)) + , ASTArr <$> smaller (listOf arbitrary) + , ASTMerge <$> + sized + (\s -> + resize (max 2 s) (listOf (halfSize arbitrary))) + , ASTEmbed <$> smaller arbitrary + , ASTString <$> arbitrary + , ASTParse <$> smaller arbitrary + , AST <$> smaller arbitrary] diff --git a/src/lib/B9/Content/ErlTerms.hs b/src/lib/B9/Content/ErlTerms.hs --- a/src/lib/B9/Content/ErlTerms.hs +++ b/src/lib/B9/Content/ErlTerms.hs @@ -9,30 +9,45 @@ ,arbitraryErlFloat ,arbitraryErlNameChar) where -import Data.Data -import Data.Function +import Control.Parallel.Strategies +import Data.Binary import qualified Data.ByteString.Char8 as B -import Text.Parsec.ByteString -import Text.Parsec -import Test.QuickCheck -import Control.Applicative ((<$>), pure, (<*>)) -import Text.Show.Pretty -import Control.Monad -import Text.Printf +import Data.Data +import Data.Function +import Data.Hashable +import GHC.Generics (Generic) +import Test.QuickCheck +import Text.Parsec + ((<|>), many, spaces, char, option, between, string, choice, + octDigit, hexDigit, many1, noneOf, try, digit, anyChar, alphaNum, + lower, parse) +import Text.Parsec.ByteString +-- #if !MIN_VERSION_base(4,8,0) +import Control.Applicative hiding ((<|>), many) +-- #endif +import Text.Show.Pretty +import Control.Monad +import Text.Printf import qualified Text.PrettyPrint as PP -import B9.QCUtil +import B9.QCUtil -- | Simplified Erlang term representation. -data SimpleErlangTerm = ErlString String - | ErlFloat Double - | ErlNatural Integer - | ErlAtom String - | ErlChar Char - | ErlBinary String - | ErlList [SimpleErlangTerm] - | ErlTuple [SimpleErlangTerm] - deriving (Eq,Ord,Read,Show,Data,Typeable) +data SimpleErlangTerm + = ErlString String + | ErlFloat Double + | ErlNatural Integer + | ErlAtom String + | ErlChar Char + | ErlBinary String + | ErlList [SimpleErlangTerm] + | ErlTuple [SimpleErlangTerm] + deriving (Eq,Ord,Read,Show,Data,Typeable,Generic) + +instance Hashable SimpleErlangTerm +instance Binary SimpleErlangTerm +instance NFData SimpleErlangTerm + -- | Parse a subset of valid Erlang terms. It parses no maps and binaries are -- restricted to either empty binaries or binaries with a string. The input diff --git a/src/lib/B9/Content/ErlangPropList.hs b/src/lib/B9/Content/ErlangPropList.hs --- a/src/lib/B9/Content/ErlangPropList.hs +++ b/src/lib/B9/Content/ErlangPropList.hs @@ -3,27 +3,38 @@ module B9.Content.ErlangPropList ( ErlangPropList (..) ) where -import Data.Data +import Control.Parallel.Strategies +import Data.Binary +import Data.Data +import Data.Function +import Data.Hashable +import Data.List (partition,sortBy) +import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.Encoding as E -import Data.Function -import Data.List (partition,sortBy) -import Data.Semigroup -import Control.Applicative -import Text.Printf +import GHC.Generics (Generic) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Text.Printf -import B9.Content.ErlTerms -import B9.Content.AST -import B9.Content.StringTemplate +import B9.Content.ErlTerms +import B9.Content.AST +import B9.Content.StringTemplate -import Test.QuickCheck +import Test.QuickCheck -- | A wrapper type around erlang terms with a Semigroup instance useful for -- combining sys.config files with OTP-application configurations in a list of -- the form of a proplist. -data ErlangPropList = ErlangPropList SimpleErlangTerm - deriving (Read,Eq,Show,Data,Typeable) +data ErlangPropList = + ErlangPropList SimpleErlangTerm + deriving (Read,Eq,Show,Data,Typeable,Generic) +instance Hashable ErlangPropList +instance Binary ErlangPropList +instance NFData ErlangPropList + instance Arbitrary ErlangPropList where arbitrary = ErlangPropList <$> arbitrary @@ -80,27 +91,32 @@ encodeSyntax (ErlangPropList t) = renderErlTerm t instance ASTish ErlangPropList where - fromAST (AST a) = pure a - fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs - where - makePair (k, ast) = do - (ErlangPropList second) <- fromAST ast - return $ ErlTuple [ErlAtom k, second] - fromAST (ASTArr xs) = - ErlangPropList . ErlList - <$> mapM (\x -> do (ErlangPropList x') <- fromAST x - return x') - xs - fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s - fromAST (ASTEmbed c) = - ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> render c - fromAST (ASTMerge []) = error "ASTMerge MUST NOT be used with an empty list!" - fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts - fromAST (ASTParse src@(Source _ srcPath)) = do - c <- readTemplateFile src - case decodeSyntax srcPath c of - Right s -> return s - Left e -> error (printf "could not parse erlang \ - \source file: '%s'\n%s\n" - srcPath - e) + fromAST (AST a) = pure a + fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs + where + makePair (k,ast) = do + (ErlangPropList second) <- fromAST ast + return $ ErlTuple [ErlAtom k, second] + fromAST (ASTArr xs) = + ErlangPropList . ErlList <$> + mapM + (\x -> + do (ErlangPropList x') <- fromAST x + return x') + xs + fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s + fromAST (ASTEmbed c) = + ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> render c + fromAST (ASTMerge []) = + error "ASTMerge MUST NOT be used with an empty list!" + fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts + fromAST (ASTParse src@(Source _ srcPath)) = do + c <- readTemplateFile src + case decodeSyntax srcPath c of + Right s -> return s + Left e -> + error + (printf + "could not parse erlang source file: '%s'\n%s\n" + srcPath + e) diff --git a/src/lib/B9/Content/Generator.hs b/src/lib/B9/Content/Generator.hs --- a/src/lib/B9/Content/Generator.hs +++ b/src/lib/B9/Content/Generator.hs @@ -2,23 +2,34 @@ composable and addressable in B9 artifacts. -} module B9.Content.Generator where -import Data.Data -import Control.Applicative +import Control.Parallel.Strategies +import Data.Binary +import Data.Data +import Data.Hashable +import GHC.Generics (Generic) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif -import B9.Content.AST -import B9.Content.ErlangPropList -import B9.Content.StringTemplate -import B9.Content.YamlObject +import B9.Content.AST +import B9.Content.ErlangPropList +import B9.Content.StringTemplate +import B9.Content.YamlObject import qualified Data.ByteString.Char8 as B -import Test.QuickCheck -import B9.QCUtil +import Test.QuickCheck +import B9.QCUtil -data Content = RenderErlang (AST Content ErlangPropList) - | RenderYaml (AST Content YamlObject) - | FromString String - | FromTextFile SourceFile - deriving (Read, Show, Typeable, Eq, Data) +data Content + = RenderErlang (AST Content ErlangPropList) + | RenderYaml (AST Content YamlObject) + | FromString String + | FromTextFile SourceFile + deriving (Read,Show,Typeable,Eq,Data,Generic) + +instance Hashable Content +instance Binary Content +instance NFData Content instance Arbitrary Content where arbitrary = oneof [FromTextFile <$> smaller arbitrary diff --git a/src/lib/B9/Content/StringTemplate.hs b/src/lib/B9/Content/StringTemplate.hs --- a/src/lib/B9/Content/StringTemplate.hs +++ b/src/lib/B9/Content/StringTemplate.hs @@ -7,13 +7,19 @@ withEnvironment) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.Arrow hiding (second) import Control.Monad.Reader import Data.Bifunctor import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB +import Control.Parallel.Strategies +import GHC.Generics (Generic) +import Data.Binary import Data.Data +import Data.Hashable import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding as E @@ -28,14 +34,28 @@ import B9.QCUtil -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents. -data SourceFile = Source SourceFileConversion FilePath - deriving (Read, Show, Typeable, Data, Eq) +data SourceFile = + Source SourceFileConversion + FilePath + deriving (Read,Show,Typeable,Data,Eq,Generic) -data SourceFileConversion = NoConversion | ExpandVariables - deriving (Read, Show, Typeable, Data, Eq) +instance Hashable SourceFile +instance Binary SourceFile +instance NFData SourceFile -data Environment = Environment [(String,String)] +data SourceFileConversion + = NoConversion + | ExpandVariables + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable SourceFileConversion +instance Binary SourceFileConversion +instance NFData SourceFileConversion + +newtype Environment = + Environment [(String, String)] + deriving (Read,Show,Typeable,Data,Eq,NFData,Hashable,Binary) + withEnvironment :: [(String,String)] -> ReaderT Environment m a -> m a withEnvironment env action = runReaderT action (Environment env) @@ -102,29 +122,37 @@ substFile :: MonadIO m => [(String, String)] -> FilePath -> FilePath -> m () substFile assocs src dest = do - templateBs <- liftIO (B.readFile src) - let t = templateSafe (E.decodeUtf8 templateBs) - case t of - Left (r,c) -> - let badLine = unlines (take r (lines (T.unpack (E.decodeUtf8 templateBs)))) - colMarker = replicate (c - 1) '-' ++ "^" - in error (printf "Template error in file '%s' line %i:\n\n%s\n%s\n" - src r badLine colMarker) - Right template' -> do - let out = LE.encodeUtf8 (render template' envLookup) - liftIO (LB.writeFile dest out) - return () + templateBs <- liftIO (B.readFile src) + let t = templateSafe (E.decodeUtf8 templateBs) + case t of + Left (r,c) -> + let badLine = + unlines + (take r (lines (T.unpack (E.decodeUtf8 templateBs)))) + colMarker = replicate (c - 1) '-' ++ "^" + in error + (printf + "Template error in file '%s' line %i:\n\n%s\n%s\n" + src + r + badLine + colMarker) + Right template' -> do + let out = LE.encodeUtf8 (render template' envLookup) + liftIO (LB.writeFile dest out) + return () where envT :: [(T.Text, T.Text)] envT = (T.pack *** T.pack) <$> assocs envLookup :: T.Text -> T.Text envLookup x = fromMaybe (err x) (lookup x envT) - err x = error (printf "Invalid template parameter: '%s'\n\ - \In file: '%s'\n\ - \Valid variables:\n%s\n" - (T.unpack x) - src - (ppShow assocs)) + err x = + error + (printf + "Invalid template parameter: '%s'\nIn file: '%s'\n Valid variables:\n%s\n" + (T.unpack x) + src + (ppShow assocs)) substPath :: [(String, String)] -> SystemPath -> SystemPath substPath assocs src = diff --git a/src/lib/B9/Content/YamlObject.hs b/src/lib/B9/Content/YamlObject.hs --- a/src/lib/B9/Content/YamlObject.hs +++ b/src/lib/B9/Content/YamlObject.hs @@ -4,15 +4,20 @@ ) where import Control.Applicative +import Control.Parallel.Strategies +import Data.Binary (Binary(..)) import Data.Data import Data.Function -import Data.HashMap.Strict hiding (singleton) +import Data.HashMap.Strict hiding (singleton) +import Data.Hashable +import Data.Maybe import Data.Semigroup -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Vector ((++), singleton) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Vector ((++), singleton) import Data.Yaml -import Prelude hiding ((++)) +import GHC.Generics (Generic) +import Prelude hiding ((++)) import Text.Printf import B9.Content.AST @@ -22,9 +27,20 @@ -- | A wrapper type around yaml values with a Semigroup instance useful for -- combining yaml documents describing system configuration like e.g. user-data. -data YamlObject = YamlObject Data.Yaml.Value - deriving (Eq, Data, Typeable) +data YamlObject = + YamlObject Data.Yaml.Value + deriving (Eq,Data,Typeable,Generic) +instance Hashable YamlObject +instance Binary YamlObject +instance NFData YamlObject + +instance Binary Data.Yaml.Value where + put = put . encode + get = do + v <- get + return $ fromJust $ decode v + instance Read YamlObject where readsPrec _ = readsYamlObject where @@ -73,37 +89,42 @@ E.encodeUtf8 (T.pack "#cloud-config\n") <> encode o instance ASTish YamlObject where - fromAST ast = - case ast of - ASTObj pairs -> do - ys <- mapM fromASTPair pairs - return (YamlObject (object ys)) - ASTArr asts -> do - ys <- mapM fromAST asts - let ys' = (\(YamlObject o) -> o) <$> ys - return (YamlObject (array ys')) - ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!" - ASTMerge asts -> do - ys <- mapM fromAST asts - return (foldl1 (<>) ys) - ASTEmbed c -> - YamlObject . toJSON . T.unpack . E.decodeUtf8 <$> render c - ASTString str -> - return (YamlObject (toJSON str)) - ASTParse src@(Source _ srcPath) -> do - c <- readTemplateFile src - case decodeSyntax srcPath c of - Right s -> return s - Left e -> error (printf "could not parse yaml \ - \source file: '%s'\n%s\n" - srcPath - e) - AST a -> pure a - where - fromASTPair (key, value) = do - (YamlObject o) <- fromAST value - let key' = T.pack key - return $ key' .= o + fromAST ast = + case ast of + ASTObj pairs -> do + ys <- mapM fromASTPair pairs + return (YamlObject (object ys)) + ASTArr asts -> do + ys <- mapM fromAST asts + let ys' = + (\(YamlObject o) -> + o) <$> + ys + return (YamlObject (array ys')) + ASTMerge [] -> + error "ASTMerge MUST NOT be used with an empty list!" + ASTMerge asts -> do + ys <- mapM fromAST asts + return (foldl1 (<>) ys) + ASTEmbed c -> + YamlObject . toJSON . T.unpack . E.decodeUtf8 <$> render c + ASTString str -> return (YamlObject (toJSON str)) + ASTParse src@(Source _ srcPath) -> do + c <- readTemplateFile src + case decodeSyntax srcPath c of + Right s -> return s + Left e -> + error + (printf + "could not parse yaml source file: '%s'\n%s\n" + srcPath + e) + AST a -> pure a + where + fromASTPair (key,value) = do + (YamlObject o) <- fromAST value + let key' = T.pack key + return $ key' .= o instance Arbitrary YamlObject where diff --git a/src/lib/B9/DSL.hs b/src/lib/B9/DSL.hs new file mode 100644 --- /dev/null +++ b/src/lib/B9/DSL.hs @@ -0,0 +1,348 @@ +-- | Experimental new, hopefully typesafe. domain specific language for +-- description of VM-builds. +{-# LANGUAGE FlexibleInstances #-} +module B9.DSL + (B9DSL, doc, doc', (#), Documentation(..), ($=), include, includeTemplate, writeContent, + exportCloudInit, imageSource, createImage, importImage, from, + fromResized, imageDestination, share, exportLiveInstallerImage, + exportImage, mount, lxc, lxc32, boot, exec, sh, rootImage, + dataImage, mountAndShareSharedImage, mountAndShareNewImage, runDSL, + printDSL, printBuildStep, dslExample) + where + +import B9.ArtifactGenerator (ArtifactSource(..), CloudInitType(..)) +import B9.B9Config (ExecEnvType(..)) +import B9.Content.Generator(Content) +import B9.Content.StringTemplate + (SourceFile(..), SourceFileConversion(..)) +import B9.DiskImages + (Image(..), ImageSource(..), ImageDestination(..), FileSystem(..), + Partition(..), ImageResize(..), ImageSize(..), ImageType(..), + SizeUnit(..)) +import B9.ExecEnv (CPUArch(..), SharedDirectory(..)) +import B9.ShellScript (Script(..)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid +import Control.Monad +#endif +import Control.Monad.Free (Free(..), liftF, foldFree) +import Data.Functor (void) +import Text.Printf (printf) + +data BuildStep next :: * where + Let :: String -> String -> next -> BuildStep next + Import :: + SArtifact a -> Source a -> (Imported a -> next) -> BuildStep next + Export :: SArtifact a -> Target a -> next -> BuildStep next + DefineExecEnv :: + String -> + ExecEnvType -> CPUArch -> (ExecEnv -> next) -> BuildStep next + Exec :: ExecEnv -> Script -> next -> BuildStep next + +instance Functor BuildStep where + fmap f (Let k v next) = Let k v (f next) + fmap f (Import sa src k) = Import sa src (f . k) + fmap f (Export sa dst next) = Export sa dst (f next) + fmap f (DefineExecEnv n et a k) = DefineExecEnv n et a (f . k) + fmap f (Exec et s next) = Exec et s (f next) + +type B9DSL a = Free BuildStep a + +data Tagged a b = + Tagged b + +instance Show b => Show (Tagged a b) where + show (Tagged s) = show s + +data Documentation + = Doc String + | DocIncluded Content + +data ExecEnv = + ExecEnv String + ExecEnvType + CPUArch + deriving (Show) + +type family Source (a :: Artifact) :: * where + Source 'StaticContent = ArtifactSource + Source 'VmImage = ImageSource + Source 'MountedImage = (ExecEnv, Tagged ImageSource String, FilePath) + Source 'MountedHostDirectory = (ExecEnv, FilePath, FilePath, MountOpts String) + Source 'SelfDocumentation = Documentation + +type family Imported (a :: Artifact) :: * where + Imported 'VmImage = Tagged ImageSource String + Imported a = () + +type family Target (a :: Artifact) :: * where + Target 'VmImage = (Tagged ImageSource String, ImageDestination) + Target 'CloudInit = ([CloudInitType], FilePath) + +data Artifact + = StaticContent + | VmImage + | MountedImage + | CloudInit + | MountedHostDirectory + | SelfDocumentation + +data SArtifact (k :: Artifact) where + SStaticContent :: SArtifact 'StaticContent + SVmImage :: SArtifact 'VmImage + SMountedImage :: SArtifact 'MountedImage + SCloudInit :: SArtifact 'CloudInit + SMountedHostDirectory :: SArtifact 'MountedHostDirectory + SSelfDocumentation :: SArtifact 'SelfDocumentation + +-- * For documentation of the actual build/deployment itself either embed a +-- string or a file, template parameters e.g. ${xxx} can be also used. + +doc :: String -> B9DSL () +doc str = liftF $ Import SSelfDocumentation (Doc str) id + +doc' :: Content -> B9DSL () +doc' c = liftF $ Import SSelfDocumentation (DocIncluded c) id + +(#) :: B9DSL a -> String -> B9DSL a +m # str = do + doc str + m + +-- * Content generation and static file inclusion + +($=) :: String -> String -> B9DSL () +var $= val = liftF $ Let var val () + +-- TODO split file inclusion from file content generation. i.e. add newFile +-- ... and then add an 'appendFile' function. new file should be typed according +-- to its contents so that only compatible content can be appended + +include :: FilePath -> FilePath -> B9DSL () +include dest src = liftF $ Import SStaticContent (FromFile dest (Source NoConversion src)) id + +includeTemplate :: FilePath -> FilePath -> B9DSL () +includeTemplate dest src = liftF $ Import SStaticContent (FromFile dest (Source ExpandVariables src)) id + +writeContent :: FilePath -> Content -> B9DSL () +writeContent dst src = liftF $ Import SStaticContent (FromContent dst src) id + +-- * cloud init + +exportCloudInit :: FilePath -> B9DSL () +exportCloudInit dst = liftF $ Export SCloudInit ([CI_ISO, CI_DIR], dst) () + +-- * Image import + +imageSource :: ImageSource -> B9DSL (Imported 'VmImage) +imageSource src = liftF $ Import SVmImage src id + +createImage :: String + -> FileSystem + -> ImageType + -> ImageSize + -> B9DSL (Imported 'VmImage) +createImage s fs it is = imageSource $ EmptyImage s fs it is + +importImage :: FilePath + -> ImageType + -> FileSystem + -> Partition + -> ImageResize + -> B9DSL (Imported 'VmImage) +importImage f it fs pt is = imageSource $ SourceImage (Image f it fs) pt is + +from :: String -> B9DSL (Imported 'VmImage) +from = fromResized KeepSize + +fromResized :: ImageResize -> String -> B9DSL (Imported 'VmImage) +fromResized r s = imageSource $ From s r + +-- * Image export + +imageDestination :: Imported 'VmImage + -> ImageDestination + -> B9DSL () +imageDestination img dst = liftF $ Export SVmImage (img, dst) () + +share :: Imported 'VmImage -> String -> B9DSL () +share img name = imageDestination img $ Share name QCow2 KeepSize + +exportLiveInstallerImage :: Imported 'VmImage + -> String + -> FilePath + -> ImageResize + -> B9DSL () +exportLiveInstallerImage img imgName outDir resize = + imageDestination img $ LiveInstallerImage imgName outDir resize + +exportImage :: Imported 'VmImage + -> FilePath + -> ImageType + -> FileSystem + -> ImageResize + -> B9DSL () +exportImage img name it fs resize = + imageDestination img $ LocalFile (Image name it fs) resize + +-- * Mounting + +class DSLCanMount a where + type MountArtifact a :: Artifact + data MountOpts a + defaultMountOpts :: a -> MountOpts a + mountArtifactS :: a -> SArtifact (MountArtifact a) + mountArtifact :: MountOpts a + -> ExecEnv + -> a + -> FilePath + -> Source (MountArtifact a) + +-- * Host directory +instance DSLCanMount String where + type MountArtifact String = 'MountedHostDirectory + data MountOpts String = ReadOnly | ReadWrite deriving Show + defaultMountOpts _ = ReadOnly + mountArtifactS _ = SMountedHostDirectory + mountArtifact opts e src dest = (e, src, dest, opts) + +instance DSLCanMount (Tagged ImageSource String) where + type MountArtifact (Tagged ImageSource String) = 'MountedImage + data MountOpts (Tagged ImageSource String) = MountImgNoOptions deriving Show + defaultMountOpts _ = MountImgNoOptions + mountArtifactS _ = SMountedImage + mountArtifact opts e src dest = (e, src, dest) + +mount + :: DSLCanMount src + => ExecEnv -> src -> FilePath -> B9DSL (Imported (MountArtifact src)) +mount = mount' (defaultMountOpts undefined) + +mount' + :: DSLCanMount src + => MountOpts src + -> ExecEnv + -> src + -> FilePath + -> B9DSL (Imported (MountArtifact src)) +mount' mopts e src dest = + liftF $ + Import + (mountArtifactS src) + (mountArtifact mopts e src dest) + id + +-- * Execution environment + +lxc :: String -> B9DSL ExecEnv +lxc name = boot name LibVirtLXC X86_64 + +lxc32 :: String -> B9DSL ExecEnv +lxc32 name = boot name LibVirtLXC I386 + +boot :: String -> ExecEnvType -> CPUArch -> B9DSL ExecEnv +boot name et arch = liftF $ DefineExecEnv name et arch id + +-- * Script Execution (inside a container) + +exec :: Script -> ExecEnv -> B9DSL () +exec script e = liftF $ Exec e script () + +sh :: String -> ExecEnv -> B9DSL () +sh s = exec (Run s []) + +-- TODO generalize exec to work with 'includedFiles' + +-- * Some utility vm builder lego + +rootImage :: String -> String -> ExecEnv -> B9DSL () +rootImage nameFrom nameExport env = + void $ mountAndShareSharedImage nameFrom nameExport "/" env + +dataImage :: String -> ExecEnv -> B9DSL () +dataImage nameExport env = + void $ mountAndShareNewImage "data" 64 nameExport "/data" env + +mountAndShareSharedImage :: String -> String -> String -> ExecEnv -> B9DSL (Imported 'VmImage) +mountAndShareSharedImage nameFrom nameExport mountPoint env = do + img <- from nameFrom + share img nameExport + mount env img mountPoint + return img + +mountAndShareNewImage :: String -> Int -> String -> FilePath -> ExecEnv -> B9DSL (Imported 'VmImage) +mountAndShareNewImage fsLabel sizeGB nameExport mountPoint env = do + img <- createImage fsLabel Ext4 QCow2 (ImageSize sizeGB GB) + share img nameExport + mount env img mountPoint + return img + +-- * DSL Interpreter + +#if MIN_VERSION_base(4,8,0) +runDSL + :: Monad m + => (forall a. BuildStep a -> m a) -> B9DSL b -> m b +#else +runDSL + :: (Monad m, Functor m) + => (forall a. BuildStep a -> m a) -> B9DSL b -> m b +#endif +runDSL = foldFree + +-- | Print the DSL to IO +printDSL :: B9DSL a -> IO () +printDSL = void . runDSL printBuildStep + +printBuildStep :: BuildStep a -> IO a +printBuildStep (Let k v next) = do + printf "%s := %s\n" k v + return next +printBuildStep (Import SStaticContent src k) = do + printf "import static %s\n" (show src) + return $ k () +printBuildStep (Import SVmImage src k) = do + printf "import image %s\n" (show src) + return (k (Tagged (show src))) +printBuildStep (Import SMountedImage src k) = do + printf "mount image %s\n" (show src) + return (k ()) +printBuildStep (Import SMountedHostDirectory src k) = do + printf "mount host directory %s\n" (show src) + return (k ()) +printBuildStep (Import SSelfDocumentation (Doc str) k) = do + printf "-- %s\n" str + return (k ()) +printBuildStep (Import SSelfDocumentation (DocIncluded c) k) = do + printf "-- %s\n" (show c) + return (k ()) +printBuildStep (Export SVmImage dst next) = do + printf "export image %s\n" (show dst) + return next +printBuildStep (Export SCloudInit dst next) = do + printf "export cloud-init %s\n" (show dst) + return next +printBuildStep (DefineExecEnv n et a k) = do + printf "define env: %s %s %s\n" n (show et) (show a) + return (k (ExecEnv n et a)) +printBuildStep (Exec (ExecEnv n _ _) s next) = do + printf "exec in %s: %s\n" n (show s) + return next +printBuildStep _other = do + printf "???\n" + return undefined + +-- * Tests and experiments + +dslExample :: B9DSL () +dslExample = do + "x" $= "3" + includeTemplate "httpd.conf" "httpd.conf.in" # "overwrite all of httpd!" + exportCloudInit "blah-ci" # "export the cloud-init stuff" + e <- lxc "container-id" + doc "From here there be dragons:" + mount e "/tmp" "/mnt/HOST_TMP" + rootImage "fedora" "testv1-root" e + dataImage "testv1-data" e + sh "ls -la" e diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs --- a/src/lib/B9/DiskImageBuilder.hs +++ b/src/lib/B9/DiskImageBuilder.hs @@ -154,62 +154,67 @@ createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 () createImageFromImage src part size out = do - importImage src out - extractPartition part out - resizeImage size out - + importImage src out + extractPartition part out + resizeImage size out where extractPartition :: Partition -> Image -> B9 () extractPartition NoPT _ = return () extractPartition (Partition partIndex) (Image outFile Raw _) = do - (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile) - let tmpFile = outFile <.> "extracted" - dbgL (printf "Extracting partition %i from '%s'" partIndex outFile) - cmd - (printf - "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null" - outFile - tmpFile - blockSize - start - len) - cmd (printf "mv '%s' '%s'" tmpFile outFile) + (start,len,blockSize) <- liftIO (P.getPartition partIndex outFile) + let tmpFile = outFile <.> "extracted" + dbgL (printf "Extracting partition %i from '%s'" partIndex outFile) + cmd + (printf + "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null" + outFile + tmpFile + blockSize + start + len) + cmd (printf "mv '%s' '%s'" tmpFile outFile) extractPartition (Partition partIndex) (Image outFile fmt _) = - error - (printf "Extract partition %i from \ - \image '%s': Invalid format %s" partIndex outFile - (imageFileExtension fmt)) + error + (printf + "Extract partition %i from image '%s': Invalid format %s" + partIndex + outFile + (imageFileExtension fmt)) createDestinationImage :: Image -> ImageDestination -> B9 () createDestinationImage buildImg dest = - case dest of - (Share name imgType imgResize) -> do - resizeImage imgResize buildImg - let shareableImg = changeImageFormat imgType buildImg - exportAndRemoveImage buildImg shareableImg - void (shareImage shareableImg (SharedImageName name)) - (LocalFile destImg imgResize) -> do - resizeImage imgResize buildImg - exportAndRemoveImage buildImg destImg - (LiveInstallerImage name repo imgResize) -> do - resizeImage imgResize buildImg - let destImg = Image destFile Raw buildImgFs - (Image _ _ buildImgFs) = buildImg - destFile = repo "machines" name "disks" "raw" "0.raw" - sizeFile = repo "machines" name "disks" "raw" "0.size" - versFile = repo "machines" name "disks" "raw" "VERSION" - exportAndRemoveImage buildImg destImg - cmd - (printf - "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ \ - \{print $4}' | tr -d '(') > '%s'" - destFile - sizeFile) - buildDate <- getBuildDate - buildId <- getBuildId - liftIO (writeFile versFile (buildId ++ "-" ++ buildDate)) - Transient -> - return () + case dest of + (Share name imgType imgResize) -> do + resizeImage imgResize buildImg + let shareableImg = changeImageFormat imgType buildImg + exportAndRemoveImage buildImg shareableImg + void (shareImage shareableImg (SharedImageName name)) + (LocalFile destImg imgResize) -> do + resizeImage imgResize buildImg + exportAndRemoveImage buildImg destImg + (LiveInstallerImage name repo imgResize) -> do + resizeImage imgResize buildImg + let destImg = Image destFile Raw buildImgFs + (Image _ _ buildImgFs) = buildImg + destFile = + repo "machines" name "disks" "raw" + "0.raw" + sizeFile = + repo "machines" name "disks" "raw" + "0.size" + versFile = + repo "machines" name "disks" "raw" + "VERSION" + exportAndRemoveImage buildImg destImg + cmd + (printf + "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'" + destFile + sizeFile) + buildDate <- getBuildDate + buildId <- getBuildId + liftIO (writeFile versFile (buildId ++ "-" ++ buildDate)) + Transient -> return () createEmptyImage :: String -> FileSystem @@ -218,33 +223,42 @@ -> Image -> B9 () createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType') - | fsType /= fsType' = error - (printf - "Conflicting createEmptyImage parameters. \ - \Requested is file system %s but the destination \ - \image has %s." - (show fsType) - (show fsType')) - | imgType /= imgType' = error - (printf - "Conflicting createEmptyImage parameters. \ - \Requested is image type %s but the destination \ - \image has type %s." - (show imgType) - (show imgType')) + | fsType /= fsType' = + error + (printf + "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s." + (show fsType) + (show fsType')) + | imgType /= imgType' = + error + (printf + "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s." + (show imgType) + (show imgType')) | otherwise = do let (Image imgFile imgFmt imgFs) = dest - dbgL (printf "Creating empty raw image '%s' with size %s" imgFile (toQemuSizeOptVal imgSize)) + dbgL + (printf + "Creating empty raw image '%s' with size %s" + imgFile + (toQemuSizeOptVal imgSize)) cmd - (printf "qemu-img create -f %s '%s' '%s'" (imageFileExtension imgFmt) imgFile - (toQemuSizeOptVal imgSize)) + (printf + "qemu-img create -f %s '%s' '%s'" + (imageFileExtension imgFmt) + imgFile + (toQemuSizeOptVal imgSize)) case (imgFmt, imgFs) of - (Raw, Ext4) -> do - let fsCmd = "mkfs.ext4" - dbgL (printf "Creating file system %s" (show imgFs)) - cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile) - (it, fs) -> - error (printf "Cannot create file system %s in image type %s" (show fs) (show it)) + (Raw,Ext4) -> do + let fsCmd = "mkfs.ext4" + dbgL (printf "Creating file system %s" (show imgFs)) + cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile) + (it,fs) -> + error + (printf + "Cannot create file system %s in image type %s" + (show fs) + (show it)) createCOWImage :: Image -> Image -> B9 () diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs --- a/src/lib/B9/DiskImages.hs +++ b/src/lib/B9/DiskImages.hs @@ -3,8 +3,14 @@ module B9.DiskImages where import B9.QCUtil +import GHC.Generics (Generic) +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif +import Control.Parallel.Strategies +import Data.Binary import Data.Data +import Data.Hashable import Data.Maybe import Data.Semigroup import System.FilePath @@ -22,12 +28,20 @@ ImageDestination ImageSource MountPoint - deriving (Read, Show, Typeable, Data, Eq) + deriving (Read, Show, Typeable, Data, Eq,Generic) +instance Hashable ImageTarget +instance Binary ImageTarget +instance NFData ImageTarget + -- | A mount point or 'NotMounted' data MountPoint = MountPoint FilePath | NotMounted - deriving (Show, Read, Typeable, Data, Eq) + deriving (Show, Read, Typeable, Data, Eq,Generic) +instance Hashable MountPoint +instance Binary MountPoint +instance NFData MountPoint + -- | The destination of an image. data ImageDestination = Share String ImageType ImageResize -- ^ Create the image and some meta data so that other @@ -43,8 +57,12 @@ -- objective of the b9 build is not an image file, but -- rather some artifact produced by executing by a -- containerize build. - deriving (Read, Show, Typeable, Data,Eq) + deriving (Read, Show, Typeable, Data,Eq,Generic) +instance Hashable ImageDestination +instance Binary ImageDestination +instance NFData ImageDestination + -- | Specification of how the image to build is obtained. data ImageSource = EmptyImage String FileSystem ImageType ImageSize -- ^ Create an empty image file having a file system label @@ -59,38 +77,66 @@ -- the partition table and extract it using @dd@. | From String ImageResize -- ^ Use an image previously shared by via 'Share'. - deriving (Show,Read,Typeable,Data,Eq) + deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable ImageSource +instance Binary ImageSource +instance NFData ImageSource + -- | The partition to extract. data Partition = NoPT -- ^ There is no partition table on the image | Partition Int -- ^ Extract partition @n@ @n@ must be in @0..3@ - deriving (Eq, Show, Read, Typeable, Data) + deriving (Eq, Show, Read, Typeable, Data,Generic) +instance Hashable Partition +instance Binary Partition +instance NFData Partition + -- | A vm disk image file consisting of a path to the image file, and the type -- and file system. data Image = Image FilePath ImageType FileSystem - deriving (Eq, Show, Read, Typeable, Data) + deriving (Eq, Show, Read, Typeable, Data,Generic) +instance Hashable Image +instance Binary Image +instance NFData Image + -- | An image type defines the actual /file format/ of a file containing file -- systems. These are like /virtual harddrives/ data ImageType = Raw | QCow2 | Vmdk - deriving (Eq,Read,Typeable,Data,Show) + deriving (Eq,Read,Typeable,Data,Show,Generic) +instance Hashable ImageType +instance Binary ImageType +instance NFData ImageType + -- | The file systems that b9 can use and convert. data FileSystem = NoFileSystem | Ext4 | ISO9660 | VFAT - deriving (Eq,Show,Read,Typeable,Data) + deriving (Eq,Show,Read,Typeable,Data,Generic) +instance Hashable FileSystem +instance Binary FileSystem +instance NFData FileSystem + -- | A data type for image file or file system size; instead of passing 'Int's -- around this also captures a size unit so that the 'Int' can be kept small data ImageSize = ImageSize Int SizeUnit - deriving (Eq, Show, Read, Typeable, Data) + deriving (Eq, Show, Read, Typeable, Data, Generic) +instance Hashable ImageSize +instance Binary ImageSize +instance NFData ImageSize + -- | Enumeration of size multipliers. The exact semantics may vary depending on -- what external tools look at these. E.g. the size unit is convert to a size -- parameter of the @qemu-img@ command line tool. data SizeUnit = B | KB | MB | GB - deriving (Eq, Show, Read, Ord, Typeable, Data) + deriving (Eq, Show, Read, Ord, Typeable, Data, Generic) +instance Hashable SizeUnit +instance Binary SizeUnit +instance NFData SizeUnit + -- | How to resize an image file. data ImageResize = ResizeImage ImageSize -- ^ Resize the image __but not the file system__. Note that @@ -105,8 +151,12 @@ -- smallest size to fit the contents of the file system. | KeepSize -- ^ Do not change the image size. - deriving (Eq, Show, Read, Typeable, Data) + deriving (Eq, Show, Read, Typeable, Data, Generic) +instance Hashable ImageResize +instance Binary ImageResize +instance NFData ImageResize + -- | A type alias that indicates that something of type @a@ is mount at a -- 'MountPoint' type Mounted a = (a, MountPoint) @@ -122,18 +172,22 @@ SharedImageBuildId ImageType FileSystem - deriving (Eq,Read,Show) + deriving (Eq,Read,Show,Typeable,Data,Generic) +instance Hashable SharedImage +instance Binary SharedImage +instance NFData SharedImage + -- | The name of the image is the de-facto identifier for push, pull, 'From' and -- 'Share'. B9 always selects the newest version the shared image identified -- by that name when using a shared image as an 'ImageSource'. This is a -- wrapper around a string that identifies a 'SharedImage' -newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show) +newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData) -- | The exact time that build job __started__. -- This is a wrapper around a string contains the build date of a -- 'SharedImage'; this is purely additional convenience and typesafety -newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show) +newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData) -- | Every B9 build running in a 'B9Monad' -- contains a random unique id that is generated once per build (no matter how @@ -141,7 +195,7 @@ -- of the build that created the shared image instance. This is A wrapper -- around a string contains the build id of a 'SharedImage'; this is purely -- additional convenience and typesafety -newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show) +newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData) -- | Shared images are orderd by name, build date and build id instance Ord SharedImage where diff --git a/src/lib/B9/ExecEnv.hs b/src/lib/B9/ExecEnv.hs --- a/src/lib/B9/ExecEnv.hs +++ b/src/lib/B9/ExecEnv.hs @@ -14,47 +14,80 @@ RamSize(..), ) where +import Control.Parallel.Strategies +import Data.Binary import Data.Data +import Data.Hashable import Data.Monoid import B9.DiskImages +import GHC.Generics (Generic) -data ExecEnv = ExecEnv { envName :: String - , envImageMounts :: [Mounted Image] - , envSharedDirectories :: [SharedDirectory] - , envResources :: Resources - } +data ExecEnv = ExecEnv + { envName :: String + , envImageMounts :: [Mounted Image] + , envSharedDirectories :: [SharedDirectory] + , envResources :: Resources + } + deriving (Read,Show,Typeable,Data,Eq,Generic) -data SharedDirectory = SharedDirectory FilePath MountPoint - | SharedDirectoryRO FilePath MountPoint - | SharedSources MountPoint - deriving (Read, Show, Typeable, Data, Eq) +instance Hashable ExecEnv +instance Binary ExecEnv +instance NFData ExecEnv -data Resources = Resources { maxMemory :: RamSize - , cpuCount :: Int - , cpuArch :: CPUArch - } - deriving (Read, Show, Typeable, Data) +data SharedDirectory + = SharedDirectory FilePath + MountPoint + | SharedDirectoryRO FilePath + MountPoint + | SharedSources MountPoint + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable SharedDirectory +instance Binary SharedDirectory +instance NFData SharedDirectory + +data Resources = Resources + { maxMemory :: RamSize + , cpuCount :: Int + , cpuArch :: CPUArch + } deriving (Eq,Read,Show,Typeable,Data,Generic) + +instance Hashable Resources +instance Binary Resources +instance NFData Resources + instance Monoid Resources where - mempty = Resources mempty 1 mempty - mappend (Resources m c a) (Resources m' c' a') = Resources (m <> m') (max c c') (a <> a') + mempty = Resources mempty 1 mempty + mappend (Resources m c a) (Resources m' c' a') = + Resources (m <> m') (max c c') (a <> a') noResources :: Resources noResources = mempty -data CPUArch = X86_64 - | I386 - deriving (Read, Show, Typeable, Data, Eq) +data CPUArch + = X86_64 + | I386 + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable CPUArch +instance Binary CPUArch +instance NFData CPUArch + instance Monoid CPUArch where mempty = I386 I386 `mappend` x = x X86_64 `mappend` _ = X86_64 -data RamSize = RamSize Int SizeUnit - | AutomaticRamSize - deriving (Eq, Read, Show, Ord, Typeable, Data) +data RamSize + = RamSize Int + SizeUnit + | AutomaticRamSize + deriving (Eq,Read,Show,Ord,Typeable,Data,Generic) + +instance Hashable RamSize +instance Binary RamSize +instance NFData RamSize instance Monoid RamSize where mempty = AutomaticRamSize diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs --- a/src/lib/B9/LibVirtLXC.hs +++ b/src/lib/B9/LibVirtLXC.hs @@ -215,39 +215,11 @@ -> FilePath -> String createDomain cfg e buildId uuid scriptDirHost scriptDirGuest = - "\n\ - \ " ++ buildId ++ "\n\ - \ " ++ uuid ++ "\n\ - \ " ++ memoryAmount cfg e ++ "\n\ - \ " ++ memoryAmount cfg e ++ "\n\ - \ " ++ cpuCountStr e ++ "\n\ - \ \n\ - \ \n\ - \ "++ renderGuestCapabilityEntries cfg ++"\n\ - \ \n\ - \ \n\ - \ \n\ - \ exe\n\ - \ " ++ scriptDirGuest initScript ++ "\n\ - \ \n\ - \ \n\ - \ destroy\n\ - \ restart\n\ - \ destroy\n\ - \ \n\ - \ " ++ emulator cfg ++ "\n" + "\n " ++ buildId ++ "\n " ++ uuid ++ "\n " ++ memoryAmount cfg e ++ "\n " ++ memoryAmount cfg e ++ "\n " ++ cpuCountStr e ++ "\n \n \n "++ renderGuestCapabilityEntries cfg ++"\n \n \n \n exe\n " ++ scriptDirGuest initScript ++ "\n \n \n destroy\n restart\n destroy\n \n " ++ emulator cfg ++ "\n" ++ unlines (libVirtNetwork (networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e)) ++ "\n" ++ - " \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \\n" + " \n \n \n \n \n \n \n \n\n" renderGuestCapabilityEntries :: LibVirtLXCConfig -> String renderGuestCapabilityEntries = unlines . map render . guestCapabilities diff --git a/src/lib/B9/MBR.hs b/src/lib/B9/MBR.hs --- a/src/lib/B9/MBR.hs +++ b/src/lib/B9/MBR.hs @@ -5,7 +5,9 @@ , MBR(..) , CHS(..)) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.Binary.Get import Data.Word import Text.Printf @@ -15,21 +17,23 @@ getPartition n f = decodeMBR <$> BL.readFile f where decodeMBR input = - let mbr = runGet getMBR input - part = (case n of - 1 -> mbrPart1 - 2 -> mbrPart2 - 3 -> mbrPart3 - 4 -> mbrPart4 - b -> error (printf "Error: Invalid partition index %i\ - \ only partitions 1-4 are allowed.\ - \ Image file: '%s'" - b - f)) - mbr - start = fromIntegral (primPartLbaStart part) - len = fromIntegral (primPartSectors part) - in (start * sectorSize, len * sectorSize) + let mbr = runGet getMBR input + part = + (case n of + 1 -> mbrPart1 + 2 -> mbrPart2 + 3 -> mbrPart3 + 4 -> mbrPart4 + b -> + error + (printf + "Error: Invalid partition index %i only partitions 1-4 are allowed. Image file: '%s'" + b + f)) + mbr + start = fromIntegral (primPartLbaStart part) + len = fromIntegral (primPartSectors part) + in (start * sectorSize, len * sectorSize) sectorSize :: Word64 sectorSize = 512 diff --git a/src/lib/B9/PartitionTable.hs b/src/lib/B9/PartitionTable.hs --- a/src/lib/B9/PartitionTable.hs +++ b/src/lib/B9/PartitionTable.hs @@ -2,7 +2,9 @@ images. Currently only MBR partitions are supported. See 'B9.MBR' -} module B9.PartitionTable ( getPartition ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.Word ( Word64 ) import qualified B9.MBR as MBR diff --git a/src/lib/B9/QCUtil.hs b/src/lib/B9/QCUtil.hs --- a/src/lib/B9/QCUtil.hs +++ b/src/lib/B9/QCUtil.hs @@ -3,7 +3,9 @@ -} module B9.QCUtil where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Control.Monad import Test.QuickCheck diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs --- a/src/lib/B9/Repository.hs +++ b/src/lib/B9/Repository.hs @@ -21,7 +21,9 @@ import Control.Monad import Control.Monad.IO.Class +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.Data import Data.List import Data.ConfigFile diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs --- a/src/lib/B9/RepositoryIO.hs +++ b/src/lib/B9/RepositoryIO.hs @@ -81,28 +81,22 @@ -- | Push a file from the cache to a remote repository pullGlob :: FilePath -> FilePathGlob -> RemoteRepo -> B9 () -pullGlob subDir glob repo@(RemoteRepo repoId - rootDir - _key - (SshRemoteHost (host, _port)) - (SshRemoteUser user)) = do - cache <- getRepoCache - infoL (printf "SYNCING REPO METADATA '%s'" repoId) - let c = printf "rsync -rtv\ - \ --include '%s'\ - \ --exclude '*.*'\ - \ -e 'ssh %s'\ - \ '%s@%s:%s/' '%s/'" - (globToPattern glob) - (sshOpts repo) - user - host - (rootDir subDir) - destDir - destDir = repoCacheDir subDir - repoCacheDir = remoteRepoCacheDir cache repoId - ensureDir destDir - cmd c +pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host,_port)) (SshRemoteUser user)) = do + cache <- getRepoCache + infoL (printf "SYNCING REPO METADATA '%s'" repoId) + let c = + printf + "rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'" + (globToPattern glob) + (sshOpts repo) + user + host + (rootDir subDir) + destDir + destDir = repoCacheDir subDir + repoCacheDir = remoteRepoCacheDir cache repoId + ensureDir destDir + cmd c -- | Express a pattern for file paths, used when searching repositories. data FilePathGlob = FileExtension String diff --git a/src/lib/B9/ShellScript.hs b/src/lib/B9/ShellScript.hs --- a/src/lib/B9/ShellScript.hs +++ b/src/lib/B9/ShellScript.hs @@ -10,58 +10,107 @@ ) where import Data.Data +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative import Data.Monoid +#endif +import Control.Parallel.Strategies +import Data.Binary +import Data.Hashable +import GHC.Generics (Generic) import Control.Monad.Reader -import Control.Applicative ( (<$>) ) import Data.List ( intercalate ) import System.Directory ( getPermissions , setPermissions , setOwnerExecutable ) -data Script = In FilePath [Script] - | As String [Script] - | IgnoreErrors Bool [Script] - | Verbosity CmdVerbosity [Script] - | Begin [Script] - | Run FilePath [String] - | NoOP - deriving (Show, Read, Typeable, Data,Eq) +data Script + = In FilePath + [Script] + | As String + [Script] + | IgnoreErrors Bool + [Script] + | Verbosity CmdVerbosity + [Script] + | Begin [Script] + | Run FilePath + [String] + | NoOP + deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable Script +instance Binary Script +instance NFData Script + instance Monoid Script where - mempty = NoOP - NoOP `mappend` s = s - s `mappend` NoOP = s - (Begin ss) `mappend` (Begin ss') = Begin (ss ++ ss') - (Begin ss) `mappend` s' = Begin (ss ++ [s']) - s `mappend` (Begin ss') = Begin (s : ss') - s `mappend` s' = Begin [s, s'] + mempty = NoOP + NoOP `mappend` s = s + s `mappend` NoOP = s + (Begin ss) `mappend` (Begin ss') = Begin (ss ++ ss') + (Begin ss) `mappend` s' = Begin (ss ++ [s']) + s `mappend` (Begin ss') = Begin (s : ss') + s `mappend` s' = Begin [s, s'] -data Cmd = Cmd String - [String] - User - Cwd - Bool - CmdVerbosity - deriving (Show, Read) +data Cmd = + Cmd String + [String] + User + Cwd + Bool + CmdVerbosity + deriving (Show,Read,Typeable,Data,Eq,Generic) -data CmdVerbosity = Debug | Verbose | OnlyStdErr | Quiet - deriving (Show, Read, Typeable, Data,Eq) +instance Hashable Cmd +instance Binary Cmd +instance NFData Cmd -data Cwd = Cwd FilePath | NoCwd deriving (Show, Read) +data CmdVerbosity + = Debug + | Verbose + | OnlyStdErr + | Quiet + deriving (Show,Read,Typeable,Data,Eq,Generic) -data User = User String | NoUser deriving (Show, Read) +instance Hashable CmdVerbosity +instance Binary CmdVerbosity +instance NFData CmdVerbosity -data Ctx = Ctx { ctxCwd :: Cwd - , ctxUser :: User - , ctxIgnoreErrors :: Bool - , ctxVerbosity :: CmdVerbosity } +data Cwd + = Cwd FilePath + | NoCwd + deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable Cwd +instance Binary Cwd +instance NFData Cwd + +data User + = User String + | NoUser + deriving (Show,Read,Typeable,Data,Eq,Generic) + +instance Hashable User +instance Binary User +instance NFData User + +data Ctx = Ctx + { ctxCwd :: Cwd + , ctxUser :: User + , ctxIgnoreErrors :: Bool + , ctxVerbosity :: CmdVerbosity + } deriving (Show,Read,Typeable,Data,Eq,Generic) + +instance Hashable Ctx +instance Binary Ctx +instance NFData Ctx + -- | Convert 'script' to bash-shell-script written to 'file' and make 'file' -- executable. writeSh :: FilePath -> Script -> IO () writeSh file script = do - writeFile file (toBash $ toCmds script) - getPermissions file >>= setPermissions file . setOwnerExecutable True + writeFile file (toBash $ toCmds script) + getPermissions file >>= setPermissions file . setOwnerExecutable True -- | Check if a script has the same effect as 'NoOP' emptyScript :: Script -> Bool @@ -72,55 +121,75 @@ where toLLC :: Script -> Reader Ctx [Cmd] toLLC NoOP = return [] - toLLC (In d cs) = local (\ ctx -> ctx{ctxCwd = Cwd d}) - (toLLC (Begin cs)) - toLLC (As u cs) = local (\ ctx -> ctx{ctxUser = User u}) - (toLLC (Begin cs)) - toLLC (IgnoreErrors b cs) = local (\ ctx -> ctx { ctxIgnoreErrors = b }) - (toLLC (Begin cs)) - toLLC (Verbosity v cs) = local (\ ctx -> ctx { ctxVerbosity = v}) - (toLLC (Begin cs)) + toLLC (In d cs) = + local + (\ctx -> + ctx + { ctxCwd = Cwd d + }) + (toLLC (Begin cs)) + toLLC (As u cs) = + local + (\ctx -> + ctx + { ctxUser = User u + }) + (toLLC (Begin cs)) + toLLC (IgnoreErrors b cs) = + local + (\ctx -> + ctx + { ctxIgnoreErrors = b + }) + (toLLC (Begin cs)) + toLLC (Verbosity v cs) = + local + (\ctx -> + ctx + { ctxVerbosity = v + }) + (toLLC (Begin cs)) toLLC (Begin cs) = concat <$> mapM toLLC cs toLLC (Run cmd args) = do - c <- reader ctxCwd - u <- reader ctxUser - i <- reader ctxIgnoreErrors - v <- reader ctxVerbosity - return [Cmd cmd args u c i v] + c <- reader ctxCwd + u <- reader ctxUser + i <- reader ctxIgnoreErrors + v <- reader ctxVerbosity + return [Cmd cmd args u c i v] toBash :: [Cmd] -> String -toBash cmds = - intercalate "\n\n" $ - bashHeader ++ (cmdToBash <$> cmds) +toBash cmds = intercalate "\n\n" $ bashHeader ++ (cmdToBash <$> cmds) bashHeader :: [String] -bashHeader = [ "#!/bin/bash" - , "set -e" ] +bashHeader = ["#!/bin/bash", "set -e"] cmdToBash :: Cmd -> String cmdToBash (Cmd cmd args user cwd ignoreErrors verbosity) = - intercalate "\n" $ disableErrorChecking - ++ pushd cwdQ - ++ execCmd - ++ popd cwdQ - ++ reenableErrorChecking + intercalate "\n" $ + disableErrorChecking ++ + pushd cwdQ ++ execCmd ++ popd cwdQ ++ reenableErrorChecking where - execCmd = [ unwords (runuser ++ [cmd] ++ args ++ redirectOutput) ] - where runuser = case user of - NoUser -> [] - User "root" -> [] - User u -> ["runuser", "-p", "-u", u, "--"] - pushd NoCwd = [ ] - pushd (Cwd cwdPath) = [ unwords (["pushd", cwdPath] ++ redirectOutput) ] - popd NoCwd = [ ] - popd (Cwd cwdPath) = [ unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath]) ] + execCmd = [unwords (runuser ++ [cmd] ++ args ++ redirectOutput)] + where + runuser = + case user of + NoUser -> [] + User "root" -> [] + User u -> ["runuser", "-p", "-u", u, "--"] + pushd NoCwd = [] + pushd (Cwd cwdPath) = [unwords (["pushd", cwdPath] ++ redirectOutput)] + popd NoCwd = [] + popd (Cwd cwdPath) = + [unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath])] disableErrorChecking = ["set +e" | ignoreErrors] reenableErrorChecking = ["set -e" | ignoreErrors] - cwdQ = case cwd of - NoCwd -> NoCwd - Cwd d -> Cwd ("'" ++ d ++ "'") - redirectOutput = case verbosity of - Debug -> [] - Verbose -> [] - OnlyStdErr -> [">", "/dev/null"] - Quiet -> ["&>", "/dev/null"] + cwdQ = + case cwd of + NoCwd -> NoCwd + Cwd d -> Cwd ("'" ++ d ++ "'") + redirectOutput = + case verbosity of + Debug -> [] + Verbose -> [] + OnlyStdErr -> [">", "/dev/null"] + Quiet -> ["&>", "/dev/null"] diff --git a/src/lib/B9/Vm.hs b/src/lib/B9/Vm.hs --- a/src/lib/B9/Vm.hs +++ b/src/lib/B9/Vm.hs @@ -5,9 +5,13 @@ module B9.Vm (VmScript (..) ,substVmScript) where +import Control.Parallel.Strategies +import Data.Binary import Data.Data +import Data.Generics.Aliases hiding (Generic) import Data.Generics.Schemes -import Data.Generics.Aliases +import Data.Hashable +import GHC.Generics (Generic) import B9.ShellScript import B9.DiskImages @@ -16,30 +20,31 @@ -- | Describe a virtual machine, i.e. a set up disk images to create and a shell -- script to put things together. -data VmScript = VmScript CPUArch [SharedDirectory] Script - | NoVmScript - deriving (Read, Show, Typeable, Data, Eq) +data VmScript + = VmScript CPUArch + [SharedDirectory] + Script + | NoVmScript + deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable VmScript +instance Binary VmScript +instance NFData VmScript + substVmScript :: [(String,String)] -> VmScript -> VmScript substVmScript env = everywhere gsubst where - gsubst :: Data a => a -> a - gsubst = mkT substMountPoint - `extT` substSharedDir - `extT` substScript - + gsubst + :: Data a + => a -> a + gsubst = mkT substMountPoint `extT` substSharedDir `extT` substScript substMountPoint NotMounted = NotMounted substMountPoint (MountPoint x) = MountPoint (sub x) - - substSharedDir (SharedDirectory fp mp) = - SharedDirectory (sub fp) mp - substSharedDir (SharedDirectoryRO fp mp) = - SharedDirectoryRO (sub fp) mp + substSharedDir (SharedDirectory fp mp) = SharedDirectory (sub fp) mp + substSharedDir (SharedDirectoryRO fp mp) = SharedDirectoryRO (sub fp) mp substSharedDir s = s - substScript (In fp s) = In (sub fp) s substScript (Run fp args) = Run (sub fp) (map sub args) substScript (As fp s) = As (sub fp) s substScript s = s - sub = subst env diff --git a/src/tests/B9/Content/ErlangPropListSpec.hs b/src/tests/B9/Content/ErlangPropListSpec.hs --- a/src/tests/B9/Content/ErlangPropListSpec.hs +++ b/src/tests/B9/Content/ErlangPropListSpec.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module B9.Content.ErlangPropListSpec (spec) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative +#endif import Data.List import Test.Hspec import Test.QuickCheck @@ -61,9 +63,7 @@ ,ErlList [ErlNatural 1]]]) in p1 <> p2 `shouldBe` expected - it "merges two property lists into a prop list that has the lenght\ - \ of the left + the right proplist - the number of entries sharing\ - \ the same key" (property mergedPropListsHaveCorrectLength) + it "merges two property lists into a prop list that has the lenght of the left + the right proplist - the number of entries sharing the same key" (property mergedPropListsHaveCorrectLength) data ErlPropListTestData = ErlPropListTestData { plistLeft :: [SimpleErlangTerm] diff --git a/src/tests/B9/Content/YamlObjectSpec.hs b/src/tests/B9/Content/YamlObjectSpec.hs --- a/src/tests/B9/Content/YamlObjectSpec.hs +++ b/src/tests/B9/Content/YamlObjectSpec.hs @@ -20,8 +20,7 @@ ,toJSON (123::Int)]) in (v1 <> v2) `shouldBe` combined - it "combines objects with disjunct keys to an object \ - \containing all properties" $ + it "combines objects with disjunct keys to an object containing all properties" $ let plist1 = YamlObject (object ["k1" .= Number 1]) plist2 = YamlObject (object ["k2" .= Number 2]) combined = YamlObject (object ["k1" .= Number 1 @@ -35,9 +34,7 @@ ,toJSON ("y"::String)]) in (v1 <> v2) `shouldBe` combined - it "combines objects to a an object containing\ - \ all disjunct entries and combined entries\ - \ with the same keys" $ + it "combines objects to a an object containing all disjunct entries and combined entries with the same keys" $ let o1 = YamlObject (object ["k1" .= Number 1 ,"k" .= Number 2]) o2 = YamlObject (object ["k2" .= Number 3 @@ -49,31 +46,10 @@ ,Number 4]]) in (o1 <> o2) `shouldBe` combined - it "combines 'write_files' and 'runcmd' from typical 'user-data' files \ - \by merging each" $ - let (Right ud1) = decodeSyntax "" "#user-data\n\ - \\n\ - \write_files:\n\ - \ - contents: |\n\ - \ hello world!\n\ - \\n\ - \ path: /sdf/xyz/filename.cfg\n\ - \ owner: root:root\n\ - \\n\ - \runcmd:\n\ - \ - x y z\n" + it "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" $ + let (Right ud1) = decodeSyntax "" "#user-data\n\nwrite_files:\n - contents: |\n hello world!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - x y z\n" - (Right ud2) = decodeSyntax "" "#user-data\n\ - \\n\ - \write_files:\n\ - \ - contents: |\n\ - \ hello world2!\n\ - \\n\ - \ path: /sdf/xyz/filename.cfg\n\ - \ owner: root:root\n\ - \\n\ - \runcmd:\n\ - \ - a b c\n" + (Right ud2) = decodeSyntax "" "#user-data\n\nwrite_files:\n - contents: |\n hello world2!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - a b c\n" ud = YamlObject (object diff --git a/src/tests/B9/DiskImagesSpec.hs b/src/tests/B9/DiskImagesSpec.hs --- a/src/tests/B9/DiskImagesSpec.hs +++ b/src/tests/B9/DiskImagesSpec.hs @@ -20,8 +20,7 @@ itImageDestination (snd (splitToIntermediateSharedImage target name))) it - "puts the intermediate shared image name into both the \ - \intermediate and the export target" $ + "puts the intermediate shared image name into both the intermediate and the export target" $ property (\target name -> let (intermediateTarget,exportTarget) =