diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ /.idea/ *.iml +.stack-work diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,5 +1,5 @@ name: b9 -version: 0.5.10 +version: 0.5.13 synopsis: A tool and library for building virtual machine images. @@ -123,6 +123,8 @@ default-language: Haskell2010 ghc-options: -with-rtsopts=-N -Wall -fno-warn-unused-imports -fwarn-unused-binds -fno-warn-unused-do-bind + if impl(ghc >= 7.8.2) && impl(ghc < 7.10) + ghc-options: -fno-warn-amp executable b9c main-is: Main.hs @@ -137,6 +139,8 @@ default-language: Haskell2010 ghc-options: -threaded -with-rtsopts=-N -Wall -fno-warn-unused-imports -fwarn-unused-binds -fno-warn-unused-do-bind + if impl(ghc >= 7.8.2) && impl(ghc < 7.10) + ghc-options: -fno-warn-amp test-suite spec type: exitcode-stdio-1.0 @@ -148,6 +152,7 @@ , B9.Content.ErlangPropListSpec , B9.Content.YamlObjectSpec , B9.ArtifactGeneratorImplSpec + , B9.DiskImagesSpec build-depends: base >= 4.7 && < 5 , b9 , hspec @@ -160,3 +165,5 @@ , bytestring , text , semigroups + if impl(ghc >= 7.8.2) && impl(ghc < 7.10) + ghc-options: -fno-warn-amp diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -25,9 +25,12 @@ parseCommandLine :: IO B9Options parseCommandLine = - execParser (info (helper <*> (B9Options <$> globals <*> cmds <*> buildVars)) - (fullDesc - <> progDesc "Build and run VM-Images inside LXC containers.\ + execParser + (info + (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. \ @@ -35,66 +38,83 @@ \\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'" - <> headerDoc (Just helpHeader))) + \ per default located in: '~/.b9/b9.conf'" <> + headerDoc (Just helpHeader))) where - helpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. " - ++ b9Version) + helpHeader = + linebreak <> + text ("B9 - a benign VM-Image build tool v. " ++ b9Version) -data B9Options = B9Options GlobalOpts - BuildAction - BuildVariables +data B9Options = + B9Options GlobalOpts + BuildAction + BuildVariables -data GlobalOpts = GlobalOpts { configFile :: Maybe SystemPath - , cliB9Config :: B9Config } +data GlobalOpts = GlobalOpts + { configFile :: Maybe SystemPath + , cliB9Config :: B9Config + } type BuildAction = Maybe SystemPath -> ConfigParser -> B9Config -> IO Bool runB9 :: B9Options -> IO Bool runB9 (B9Options globalOpts action vars) = do - let cfgWithArgs = cfgCli { envVars = envVars cfgCli ++ vars } - cfgCli = cliB9Config globalOpts - cfgFile = configFile globalOpts - cp <- configure cfgFile cfgCli - action cfgFile cp cfgWithArgs + let cfgWithArgs = + cfgCli + { envVars = envVars cfgCli ++ vars + } + cfgCli = cliB9Config globalOpts + cfgFile = configFile globalOpts + cp <- configure cfgFile cfgCli + action cfgFile cp cfgWithArgs runShowVersion :: BuildAction runShowVersion _cfgFile _cp _conf = do - putStrLn b9Version - return True + putStrLn b9Version + return True runBuildArtifacts :: [FilePath] -> BuildAction runBuildArtifacts buildFiles _cfgFile cp conf = do - generators <- mapM consult buildFiles - buildArtifacts (mconcat generators) cp conf + generators <- mapM consult buildFiles + buildArtifacts (mconcat generators) cp conf runFormatBuildFiles :: [FilePath] -> BuildAction runFormatBuildFiles buildFiles _cfgFile _cp _conf = do - generators <- mapM consult buildFiles - let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator]) - putStrLn `mapM` (generatorsFormatted) - (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted) - return True + generators <- mapM consult buildFiles + let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator]) + putStrLn `mapM` (generatorsFormatted) + (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted) + return True runPush :: SharedImageName -> BuildAction runPush name _cfgFile cp conf = impl where - conf' = conf { keepTempDirs = False } - impl = run cp conf' - (if not (isJust (repository conf')) - then do - errorL "No repository specified! \ + conf' = + conf + { keepTempDirs = False + } + impl = + run + cp + conf' + (if not (isJust (repository conf')) + then do + errorL + "No repository specified! \ \ Use '-r' to specify a repo BEFORE 'push'." return False - else do + else do pushSharedImageLatestVersion name return True) runPull :: Maybe SharedImageName -> BuildAction runPull mName _cfgFile cp conf = - run cp conf' (pullRemoteRepos >> maybePullImage) + run cp conf' (pullRemoteRepos >> maybePullImage) where - conf' = conf { keepTempDirs = False } + conf' = + conf + { keepTempDirs = False + } maybePullImage = maybe (return True) pullLatestImage mName runRun :: SharedImageName -> [String] -> BuildAction @@ -214,89 +234,101 @@ runAddRepo :: RemoteRepo -> BuildAction runAddRepo repo cfgFile cp _conf = do - repo' <- remoteRepoCheckSshPrivKey repo - case writeRemoteRepoConfig repo' cp of - Left er -> - error (printf "Failed to add remote repo '%s'\ + repo' <- remoteRepoCheckSshPrivKey repo + case writeRemoteRepoConfig repo' cp of + Left er -> + error + (printf + "Failed to add remote repo '%s'\ \ to b9 configuration. The \ \error was: \"%s\"." - (show repo) (show er)) - - Right cpWithRepo -> - writeB9Config cfgFile cpWithRepo - return True + (show repo) + (show er)) + Right cpWithRepo -> writeB9Config cfgFile cpWithRepo + return True globals :: Parser GlobalOpts -globals = toGlobalOpts - <$> optional (strOption - (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" - <> short 'c' - <> long "configuration-file" - <> metavar "FILENAME")) - <*> switch (help "Log everything that happens to stdout" - <> short 'v' - <> long "verbose") - <*> switch (help "Suppress non-error output" - <> short 'q' - <> long "quiet") - <*> optional (strOption - (help "Path to a logfile" - <> short 'l' - <> long "log-file" - <> metavar "FILENAME")) - <*> optional (strOption - (help "Output file for a command/timing profile" - <> long "profile-file" - <> metavar "FILENAME")) - <*> optional (strOption - (help "Root directory for build directories" - <> short 'b' - <> long "build-root-dir" - <> metavar "DIRECTORY")) - <*> switch (help "Keep build directories after exit" - <> short 'k' - <> long "keep-build-dir") - <*> switch (help "Predictable build directory names" - <> short 'u' - <> long "predictable-build-dir") - <*> optional (strOption - (help "Cache directory for shared images, default: '~/.b9/repo-cache'" - <> long "repo-cache" - <> metavar "DIRECTORY")) - <*> optional (strOption - (help "Remote repository to share image to" - <> short 'r' - <> long "repo" - <> metavar "REPOSITORY_ID")) - +globals = + toGlobalOpts <$> + optional + (strOption + (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> + short 'c' <> + long "configuration-file" <> + metavar "FILENAME")) <*> + switch + (help "Log everything that happens to stdout" <> short 'v' <> + long "verbose") <*> + switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*> + optional + (strOption + (help "Path to a logfile" <> short 'l' <> long "log-file" <> + metavar "FILENAME")) <*> + optional + (strOption + (help "Output file for a command/timing profile" <> + long "profile-file" <> + metavar "FILENAME")) <*> + optional + (strOption + (help "Root directory for build directories" <> short 'b' <> + long "build-root-dir" <> + metavar "DIRECTORY")) <*> + switch + (help "Keep build directories after exit" <> short 'k' <> + long "keep-build-dir") <*> + switch + (help "Predictable build directory names" <> short 'u' <> + long "predictable-build-dir") <*> + optional + (strOption + (help + "Cache directory for shared images, default: '~/.b9/repo-cache'" <> + long "repo-cache" <> + metavar "DIRECTORY")) <*> + optional + (strOption + (help "Remote repository to share image to" <> short 'r' <> + long "repo" <> + metavar "REPOSITORY_ID")) where - toGlobalOpts :: Maybe FilePath - -> Bool - -> Bool - -> Maybe FilePath - -> Maybe FilePath - -> Maybe FilePath - -> Bool - -> Bool - -> Maybe FilePath - -> Maybe String - -> GlobalOpts - toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique - mRepoCache repo = - let minLogLevel = if verbose then Just LogTrace else - if quiet then Just LogError else Nothing - b9cfg' = let b9cfg = mempty { verbosity = minLogLevel - , logFile = logF - , profileFile = profF - , buildDirRoot = buildRoot - , keepTempDirs = keep - , uniqueBuildDirs = not notUnique - , repository = repo - } - in b9cfg { repositoryCache = Path <$> mRepoCache } - - in GlobalOpts { configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile - , cliB9Config = b9cfg' } + toGlobalOpts + :: Maybe FilePath + -> Bool + -> Bool + -> Maybe FilePath + -> Maybe FilePath + -> Maybe FilePath + -> Bool + -> Bool + -> Maybe FilePath + -> Maybe String + -> GlobalOpts + toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique mRepoCache repo = + let minLogLevel = + if verbose + then Just LogTrace + else if quiet + then Just LogError + else Nothing + b9cfg' = + let b9cfg = + mempty + { verbosity = minLogLevel + , logFile = logF + , profileFile = profF + , buildDirRoot = buildRoot + , keepTempDirs = keep + , uniqueBuildDirs = not notUnique + , repository = repo + } + in b9cfg + { repositoryCache = Path <$> mRepoCache + } + in GlobalOpts + { configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile + , cliB9Config = b9cfg' + } cmds :: Parser BuildAction cmds = @@ -373,48 +405,50 @@ (progDesc "Re-Format all build files."))) buildFileParser :: Parser [FilePath] -buildFileParser = helper <*> - some (strOption - (help "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" - <> noArgError (ErrorMsg "No build file specified!"))) +buildFileParser = + helper <*> + some + (strOption + (help + "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" <> + noArgError (ErrorMsg "No build file specified!"))) buildVars :: Parser BuildVariables -buildVars = zip (("arg_"++) . show <$> ([1..] :: [Int])) - <$> many (strArgument idm) +buildVars = + zip (("arg_" ++) . show <$> ([1 ..] :: [Int])) <$> many (strArgument idm) remoteRepoParser :: Parser RemoteRepo remoteRepoParser = - helper <*> - (RemoteRepo <$> strArgument (help "The name of the remmote repository." - <> metavar "NAME") - <*> strArgument (help "The (remote) repository root path." - <> metavar "REMOTE_DIRECTORY") - <*> (SshPrivKey - <$> strArgument (help "Path to the SSH private\ + helper <*> + (RemoteRepo <$> + strArgument (help "The name of the remmote repository." <> metavar "NAME") <*> + strArgument + (help "The (remote) repository root path." <> + metavar "REMOTE_DIRECTORY") <*> + (SshPrivKey <$> + strArgument + (help + "Path to the SSH private\ \ key file used for \ - \ authorization." - <> metavar "SSH_PRIV_KEY_FILE")) - <*> (SshRemoteHost - <$> ((,) - <$> strArgument (help "Repo hostname or IP" - <> metavar "HOST") - <*> argument auto (help "SSH-Port number" - <> value 22 - <> showDefault - <> metavar "PORT"))) - <*> (SshRemoteUser <$> strArgument (help "SSH-User to login" - <> metavar "USER"))) + \ authorization." <> + metavar "SSH_PRIV_KEY_FILE")) <*> + (SshRemoteHost <$> + ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*> + argument + auto + (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*> + (SshRemoteUser <$> + strArgument (help "SSH-User to login" <> metavar "USER"))) sharedImageNameParser :: Parser SharedImageName sharedImageNameParser = - helper <*> - (SharedImageName <$> strArgument - (help "Shared image name" - <> metavar "NAME")) + helper <*> + (SharedImageName <$> + strArgument (help "Shared image name" <> metavar "NAME")) b9Version :: String b9Version = showVersion version 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 @@ -4,23 +4,15 @@ Top-Level data types for B9 build artifacts. -} module B9.ArtifactGenerator - (ArtifactGenerator(..) - ,ArtifactSource(..) - ,InstanceId(..) - ,ArtifactTarget(..) - ,CloudInitType(..) - ,ArtifactAssembly(..) - ,AssembledArtifact(..) - --,YamlValue (..) - ,instanceIdKey - ,buildIdKey - ,buildDateKey - ,getAssemblyOutputFiles - ) where + (ArtifactGenerator(..), ArtifactSource(..), InstanceId(..), + ArtifactTarget(..), CloudInitType(..), ArtifactAssembly(..), + AssembledArtifact(..), instanceIdKey, buildIdKey, buildDateKey, + getAssemblyOutputFiles) + where import Data.Data -import Data.Monoid -- hiding ((<>)) +import Data.Monoid import Control.Applicative import System.FilePath ((<.>), ()) @@ -47,12 +39,15 @@ @ The reasons why 'Sources' takes a list of 'ArtifactGenerator's is that -1. this makes the value easier to read/write for humans -2. the sources are static files used in all children (e.g. company logo image) -3. the sources are parameterized by variables that bound to different values - for each artifact, e.g. a template network config file which contains - the host IP address. + 1. this makes the value easier to read/write for humans + + 2. the sources are static files used in all children (e.g. company logo image) + + 3. the sources are parameterized by variables that bound to different values + for each artifact, e.g. a template network config file which contains + the host IP address. + To bind such variables use 'Let', 'Each', 'LetX' or 'EachT'. String subtitution of these variables is done by "B9.Content.StringTemplate". @@ -60,87 +55,116 @@ and in source files added with 'B9.Content.StringTemplate.SourceFile' -} -data ArtifactGenerator = Sources [ArtifactSource] [ArtifactGenerator] - -- ^ Add sources available to 'ArtifactAssembly's in - -- nested artifact generators. - | Let [(String, String)] [ArtifactGenerator] - -- ^ Bind variables, variables are avaible in nested - -- generators. - | LetX [(String, [String])] [ArtifactGenerator] - -- ^ A 'Let' where each variable is assigned to each - -- value; the nested generator is executed for each - -- permutation. - -- - -- @ - -- LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..] - -- @ - -- Is equal to: - -- - -- @ - -- Let [] [ - -- Let [("x", "1"), ("y", "a")] [..] - -- Let [("x", "1"), ("y", "b")] [..] - -- Let [("x", "2"), ("y", "a")] [..] - -- Let [("x", "2"), ("y", "b")] [..] - -- Let [("x", "3"), ("y", "a")] [..] - -- Let [("x", "3"), ("y", "b")] [..] - -- ] - -- @ - | Each [(String,[String])] [ArtifactGenerator] - -- ^ Bind each variable to their first value, then each - -- variable to the second value, etc ... and execute the - -- nested generator in every step. 'LetX' represents a - -- product of all variables, whereas 'Each' represents a - -- sum of variable bindings - 'Each' is more like a /zip/ - -- whereas 'LetX' is more like a list comprehension. - | EachT [String] [[String]] [ArtifactGenerator] - -- ^ The transposed verison of 'Each': Bind the variables - -- in the first list to each a set of values from the - -- second argument; execute the nested generators for - -- each binding - | Artifact InstanceId ArtifactAssembly - -- ^ Generate an artifact defined by an - -- 'ArtifactAssembly'; the assembly can access the files - -- created from the 'Sources' and variables bound by - -- 'Let'ish elements. An artifact has an instance id, - -- that is a unique, human readable string describing the - -- artifact to assemble. - | EmptyArtifact - deriving (Read, Show, Eq) +data ArtifactGenerator + = Sources [ArtifactSource] + [ArtifactGenerator] + | + -- ^ Add sources available to 'ArtifactAssembly's in + -- nested artifact generators. + Let [(String, String)] + [ArtifactGenerator] + | + -- ^ Bind variables, variables are avaible in nested + -- generators. + LetX [(String, [String])] + [ArtifactGenerator] + | + -- ^ A 'Let' where each variable is assigned to each + -- value; the nested generator is executed for each + -- permutation. + -- + -- @ + -- LetX [("x", ["1","2","3"]), ("y", ["a","b"])] [..] + -- @ + -- Is equal to: + -- + -- @ + -- Let [] [ + -- Let [("x", "1"), ("y", "a")] [..] + -- Let [("x", "1"), ("y", "b")] [..] + -- Let [("x", "2"), ("y", "a")] [..] + -- Let [("x", "2"), ("y", "b")] [..] + -- Let [("x", "3"), ("y", "a")] [..] + -- Let [("x", "3"), ("y", "b")] [..] + -- ] + -- @ + Each [(String, [String])] + [ArtifactGenerator] + | + -- ^ Bind each variable to their first value, then each + -- variable to the second value, etc ... and execute the + -- nested generator in every step. 'LetX' represents a + -- product of all variables, whereas 'Each' represents a + -- sum of variable bindings - 'Each' is more like a /zip/ + -- whereas 'LetX' is more like a list comprehension. + EachT [String] + [[String]] + [ArtifactGenerator] + | + -- ^ The transposed verison of 'Each': Bind the variables + -- in the first list to each a set of values from the + -- second argument; execute the nested generators for + -- each binding + Artifact InstanceId + ArtifactAssembly + | + -- ^ Generate an artifact defined by an + -- 'ArtifactAssembly'; the assembly can access the files + -- created from the 'Sources' and variables bound by + -- 'Let'ish elements. An artifact has an instance id, + -- that is a unique, human readable string describing the + -- artifact to assemble. + EmptyArtifact + deriving (Read,Show,Eq,Data,Typeable) instance Monoid ArtifactGenerator where - mempty = Let [] [] - (Let [] []) `mappend` x = x - x `mappend` (Let [] []) = x - x `mappend` y = Let [] [x, y] + mempty = Let [] [] + (Let [] []) `mappend` x = x + x `mappend` (Let [] []) = x + x `mappend` y = Let [] [x, y] -- | Describe how input files for artifacts to build are obtained. The general -- structure of each constructor is __FromXXX__ /destination/ /source/ -data ArtifactSource = FromFile FilePath SourceFile - -- ^ Copy a 'B9.Content.StringTemplate.SourceFile' - -- potentially replacing variabled defined in 'Let'-like - -- parent elements. - | FromContent FilePath Content - -- ^ Create a file from some 'Content' - | SetPermissions Int Int Int [ArtifactSource] - -- ^ Set the unix /file permissions/ to all files generated - -- by the nested list of 'ArtifactSource's. - | FromDirectory FilePath [ArtifactSource] - -- ^ Assume a local directory as starting point for all - -- relative source files in the nested 'ArtifactSource's. - | IntoDirectory FilePath [ArtifactSource] - -- ^ Specify an output directory for all the files - -- generated by the nested 'ArtifactSource's - | Concatenation FilePath [ArtifactSource] - -- ^ __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 ArtifactSource + = FromFile FilePath + SourceFile + | + -- ^ Copy a 'B9.Content.StringTemplate.SourceFile' + -- potentially replacing variabled defined in 'Let'-like + -- parent elements. + FromContent FilePath + Content + | + -- ^ Create a file from some 'Content' + SetPermissions Int + Int + Int + [ArtifactSource] + | + -- ^ Set the unix /file permissions/ to all files generated + -- by the nested list of 'ArtifactSource's. + FromDirectory FilePath + [ArtifactSource] + | + -- ^ Assume a local directory as starting point for all + -- relative source files in the nested 'ArtifactSource's. + IntoDirectory FilePath + [ArtifactSource] + | + -- ^ Specify an output directory for all the files + -- generated by the nested 'ArtifactSource's + Concatenation FilePath + [ArtifactSource] + -- ^ __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) -- | 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) +newtype InstanceId = + IID String + deriving (Read,Show,Typeable,Data,Eq) -- | The variable containing the instance id. __Deprecated__ instanceIdKey :: String @@ -161,93 +185,104 @@ -- | Define an __output__ of a build. Assemblies are nested into -- 'ArtifactGenerator's. They contain all the files defined by the 'Sources' -- they are nested into. -data ArtifactAssembly = CloudInit [CloudInitType] FilePath - -- ^ Generate a __cloud-init__ compatible directory, ISO- - -- or VFAT image, as specified by the list of - -- 'CloudInitType's. Every item will use the second - -- argument to create an appropriate /file name/, - -- e.g. for the 'CI_ISO' type the output is @second_param.iso@. - | VmImages [ImageTarget] VmScript - -- ^ a set of VM-images that were created by executing a - -- build script on them. - deriving (Read, Show, Typeable, Data, Eq) +data ArtifactAssembly + = CloudInit [CloudInitType] + FilePath + | + -- ^ Generate a __cloud-init__ compatible directory, ISO- + -- or VFAT image, as specified by the list of + -- 'CloudInitType's. Every item will use the second + -- argument to create an appropriate /file name/, + -- e.g. for the 'CI_ISO' type the output is @second_param.iso@. + VmImages [ImageTarget] + VmScript + -- ^ a set of VM-images that were created by executing a + -- build script on them. + deriving (Read,Show,Typeable,Data,Eq) -- | 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 -- three output files, a directory, an ISO image and a VFAT image. -data AssembledArtifact = AssembledArtifact InstanceId [ArtifactTarget] - deriving (Read, Show, Typeable, Data, Eq) +data AssembledArtifact = + AssembledArtifact InstanceId + [ArtifactTarget] + deriving (Read,Show,Typeable,Data,Eq) -data ArtifactTarget = CloudInitTarget CloudInitType FilePath - | VmImagesTarget - deriving (Read, Show, Typeable, Data, Eq) +data ArtifactTarget + = CloudInitTarget CloudInitType + FilePath + | VmImagesTarget + deriving (Read,Show,Typeable,Data,Eq) -data CloudInitType = CI_ISO | CI_VFAT | CI_DIR - deriving (Read, Show, Typeable, Data, Eq) +data CloudInitType + = CI_ISO + | CI_VFAT + | CI_DIR + deriving (Read,Show,Typeable,Data,Eq) -- | Return the files that the artifact assembly consist of. getAssemblyOutputFiles :: ArtifactAssembly -> [FilePath] getAssemblyOutputFiles (VmImages ts _) = - concatMap getImageDestinationOutputFiles ts + concatMap getImageDestinationOutputFiles ts getAssemblyOutputFiles (CloudInit ts o) = - concatMap (getCloudInitOutputFiles o) ts + concatMap (getCloudInitOutputFiles o) ts where getCloudInitOutputFiles baseName t - | t == CI_ISO = [baseName <.> "iso"] + | t == CI_ISO = [baseName <.> "iso"] | t == CI_VFAT = [baseName <.> "vfat"] - | t == CI_DIR = [baseName "meta-data" - ,baseName "user-data"] - + | t == CI_DIR = [baseName "meta-data", baseName "user-data"] + | otherwise = [] -- * QuickCheck instances instance Arbitrary ArtifactGenerator where - arbitrary = oneof [ Sources <$> halfSize arbitrary <*> halfSize arbitrary - , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary - , halfSize arbitraryEachT <*> halfSize arbitrary - , halfSize arbitraryEach <*> halfSize arbitrary - , Artifact <$> smaller arbitrary - <*> smaller arbitrary - , pure EmptyArtifact - ] + arbitrary = + oneof + [ Sources <$> halfSize arbitrary <*> halfSize arbitrary + , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary + , halfSize arbitraryEachT <*> halfSize arbitrary + , halfSize arbitraryEach <*> halfSize arbitrary + , Artifact <$> smaller arbitrary <*> smaller arbitrary + , pure EmptyArtifact] arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator) -arbitraryEachT = sized $ \n -> - EachT <$> vectorOf n (halfSize - (listOf1 - (choose ('a', 'z')))) - <*> oneof [listOf (vectorOf n (halfSize arbitrary)) - ,listOf1 (listOf (halfSize arbitrary))] +arbitraryEachT = + sized $ + \n -> + EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*> + oneof + [ listOf (vectorOf n (halfSize arbitrary)) + , listOf1 (listOf (halfSize arbitrary))] arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator) -arbitraryEach = sized $ \n -> - Each <$> listOf ((,) <$> listOf1 - (choose ('a', 'z')) - <*> vectorOf n (halfSize - (listOf1 - (choose ('a', 'z'))))) +arbitraryEach = + sized $ + \n -> + Each <$> + listOf + ((,) <$> listOf1 (choose ('a', 'z')) <*> + vectorOf n (halfSize (listOf1 (choose ('a', 'z'))))) instance Arbitrary ArtifactSource where - arbitrary = oneof [ FromFile <$> smaller arbitraryFilePath - <*> smaller arbitrary - , FromContent <$> smaller arbitraryFilePath - <*> smaller arbitrary - , SetPermissions <$> choose (0,7) - <*> choose (0,7) - <*> choose (0,7) - <*> smaller arbitrary - , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary - , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary - ] + arbitrary = + oneof + [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary + , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary + , SetPermissions <$> choose (0, 7) <*> choose (0, 7) <*> + choose (0, 7) <*> + smaller arbitrary + , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary + , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary] instance Arbitrary InstanceId where - arbitrary = IID <$> arbitraryFilePath + arbitrary = IID <$> arbitraryFilePath instance Arbitrary ArtifactAssembly where - arbitrary = oneof [ CloudInit <$> arbitrary <*> arbitraryFilePath - , pure (VmImages [] NoVmScript) - ] + arbitrary = + oneof + [ CloudInit <$> arbitrary <*> arbitraryFilePath + , VmImages <$> smaller arbitrary <*> pure NoVmScript] instance Arbitrary CloudInitType where - arbitrary = elements [CI_ISO,CI_VFAT,CI_DIR] + arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR] 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 @@ -18,7 +18,7 @@ | RenderYaml (AST Content YamlObject) | FromString String | FromTextFile SourceFile - deriving (Read, Show, Typeable, Eq) + deriving (Read, Show, Typeable, Eq, Data) instance Arbitrary Content where arbitrary = oneof [FromTextFile <$> smaller arbitrary 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 @@ -3,26 +3,27 @@ module B9.Content.YamlObject ( YamlObject (..) ) where -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Yaml -import Data.Function -import Data.HashMap.Strict hiding (singleton) -import Data.Vector ((++), singleton) -import Prelude hiding ((++)) -import Data.Semigroup -import Control.Applicative -import Text.Printf +import Control.Applicative +import Data.Data +import Data.Function +import Data.HashMap.Strict hiding (singleton) +import Data.Semigroup +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Vector ((++), singleton) +import Data.Yaml +import Prelude hiding ((++)) +import Text.Printf -import B9.Content.AST -import B9.Content.StringTemplate +import B9.Content.AST +import B9.Content.StringTemplate -import Test.QuickCheck +import Test.QuickCheck -- | 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) + deriving (Eq, Data, Typeable) instance Read YamlObject where readsPrec _ = readsYamlObject 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 @@ -2,12 +2,19 @@ images.-} module B9.DiskImages where +import B9.QCUtil import Control.Applicative import Data.Data +import Data.Maybe import Data.Semigroup import System.FilePath +import Test.QuickCheck import qualified Text.PrettyPrint.Boxes as Boxes +import Text.Printf +-- * Data types for disk image description, e.g. 'ImageTarget', +-- 'ImageDestination', 'Image', 'MountPoint', 'SharedImage' + -- | Build target for disk images; the destination, format and size of the image -- to generate, as well as how to create or obtain the image before a -- 'B9.Vm.VmScript' is executed with the image mounted at a 'MountPoint'. @@ -17,7 +24,7 @@ MountPoint deriving (Read, Show, Typeable, Data, Eq) --- | A mount point or `NotMounted` +-- | A mount point or 'NotMounted' data MountPoint = MountPoint FilePath | NotMounted deriving (Show, Read, Typeable, Data, Eq) @@ -64,15 +71,23 @@ data Image = Image FilePath ImageType FileSystem deriving (Eq, Show, Read, Typeable, Data) +-- | 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) +-- | The file systems that b9 can use and convert. data FileSystem = NoFileSystem | Ext4 | ISO9660 | VFAT deriving (Eq,Show,Read,Typeable,Data) +-- | 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) +-- | 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) @@ -92,38 +107,107 @@ -- ^ Do not change the image size. deriving (Eq, Show, Read, Typeable, Data) +-- | A type alias that indicates that something of type @a@ is mount at a +-- 'MountPoint' type Mounted a = (a, MountPoint) --- | Return the name of the file corresponding to an `Image` +-- * Shared Images + +-- | 'SharedImage' holds all data necessary to describe an __instance__ of a shared +-- image identified by a 'SharedImageName'. Shared images are stored in +-- 'B9.Repository's. +data SharedImage = + SharedImage SharedImageName + SharedImageDate + SharedImageBuildId + ImageType + FileSystem + deriving (Eq,Read,Show) + +-- | 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) + +-- | 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) + +-- | Every B9 build running in a 'B9Monad' +-- contains a random unique id that is generated once per build (no matter how +-- many artifacts are created in that build) This field contains the build id +-- 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) + +-- | Shared images are orderd by name, build date and build id +instance Ord SharedImage where + compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) = + compare n n' <> compare d d' <> compare b b' + +-- * Constroctor and accessors for 'Image' 'ImageTarget' 'ImageSource' +-- 'ImageDestination' and 'SharedImage' + +-- | Return the name of the file corresponding to an 'Image' imageFileName :: Image -> FilePath imageFileName (Image f _ _) = f --- | Return the files generated for a local or a live image; shared and transient images +-- | Return the 'ImageType' of an 'Image' +imageImageType :: Image -> ImageType +imageImageType (Image _ t _) = t + +-- | Return the files generated for a 'LocalFile' or a 'LiveInstallerImage'; 'SharedImage' and 'Transient' -- are treated like they have no ouput files because the output files are manged -- by B9. getImageDestinationOutputFiles :: ImageTarget -> [FilePath] getImageDestinationOutputFiles (ImageTarget d _ _) = - case d of - LiveInstallerImage liName liPath _ -> - let path = liPath "machines" liName "disks" "raw" - in [path "0.raw", path "0.size", path "VERSION"] - LocalFile (Image lfPath _ _) _ -> [lfPath] - _ -> [] + case d of + LiveInstallerImage liName liPath _ -> + let path = liPath "machines" liName "disks" "raw" + in [path "0.raw", path "0.size", path "VERSION"] + LocalFile (Image lfPath _ _) _ -> [lfPath] + _ -> [] +-- | Return the name of a shared image, if the 'ImageDestination' is a 'Share' +-- destination +imageDestinationSharedImageName :: ImageDestination -> Maybe SharedImageName +imageDestinationSharedImageName (Share n _ _) = Just (SharedImageName n) +imageDestinationSharedImageName _ = Nothing + +-- | Return the name of a shared source image, if the 'ImageSource' is a 'From' +-- source +imageSourceSharedImageName :: ImageSource -> Maybe SharedImageName +imageSourceSharedImageName (From n _) = Just (SharedImageName n) +imageSourceSharedImageName _ = Nothing + +-- | Get the 'ImageDestination' of an 'ImageTarget' itImageDestination :: ImageTarget -> ImageDestination itImageDestination (ImageTarget d _ _) = d +-- | Get the 'ImageSource' of an 'ImageTarget' +itImageSource :: ImageTarget -> ImageSource +itImageSource (ImageTarget _ s _) = s + +-- | Get the 'MountPoint' of an 'ImageTarget' itImageMountPoint :: ImageTarget -> MountPoint itImageMountPoint (ImageTarget _ _ m) = m + + +-- | Return true if a 'Partition' parameter is actually refering to a partition, +-- false if it is 'NoPT' isPartitioned :: Partition -> Bool -isPartitioned p | p == NoPT = False - | otherwise = True +isPartitioned p + | p == NoPT = False + | otherwise = True +-- | Return the 'Partition' index or throw a runtime error if aplied to 'NoPT' getPartition :: Partition -> Int getPartition (Partition p) = p getPartition NoPT = error "No partitions!" - -- | Return the file name extension of an image file with a specific image -- format. imageFileExtension :: ImageType -> String @@ -131,6 +215,9 @@ imageFileExtension QCow2 = "qcow2" imageFileExtension Vmdk = "vmdk" +-- | Change the image file format and also rename the image file name to +-- have the appropriate file name extension. See 'imageFileExtension' and +-- 'replaceExtension' changeImageFormat :: ImageType -> Image -> Image changeImageFormat fmt' (Image img _ fs) = Image img' fmt' fs where img' = replaceExtension img (imageFileExtension fmt') @@ -139,15 +226,15 @@ changeImageDirectory dir (Image img fmt fs) = Image img' fmt fs where img' = dir takeFileName img --- | 'SharedImage' holds all data necessary to identify an image shared. Shared --- images are stored in 'B9.Repository's. -data SharedImage = SharedImage SharedImageName - SharedImageDate - SharedImageBuildId - ImageType - FileSystem - deriving (Eq,Read,Show) +-- * Constructors and accessors for 'ImageSource's +getImageSourceImageType :: ImageSource -> Maybe ImageType +getImageSourceImageType (EmptyImage _ _ t _) = Just t +getImageSourceImageType (CopyOnWrite i) = Just $ imageImageType i +getImageSourceImageType (SourceImage i _ _) = Just $ imageImageType i +getImageSourceImageType (From _ _) = Nothing +-- * Constructors and accessors for 'SharedImage's + -- | Return the name of a shared image. siName :: SharedImage -> SharedImageName siName (SharedImage n _ _ _ _) = n @@ -160,15 +247,6 @@ siBuildId :: SharedImage -> SharedImageBuildId siBuildId (SharedImage _ _ n _ _) = n --- | Shared images are orderd by name, build date and build id -instance Ord SharedImage where - compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) = - compare n n' <> compare d d' <> compare b b' - -newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show) -newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show) -newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show) - -- | Print the contents of the shared image in one line prettyPrintSharedImages :: [SharedImage] -> String prettyPrintSharedImages imgs = Boxes.render table @@ -187,27 +265,196 @@ -- | Return the disk image of an sharedImage sharedImageImage :: SharedImage -> Image -sharedImageImage (SharedImage (SharedImageName n) - _ - (SharedImageBuildId bid) - sharedImageType - sharedImageFileSystem) = - Image (n ++ "_" ++ bid <.> imageFileExtension sharedImageType) +sharedImageImage (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) sharedImageType sharedImageFileSystem) = + Image + (n ++ "_" ++ bid <.> imageFileExtension sharedImageType) sharedImageType sharedImageFileSystem -- | Calculate the path to the text file holding the serialized 'SharedImage' -- relative to the directory of shared images in a repository. sharedImageFileName :: SharedImage -> FilePath -sharedImageFileName (SharedImage (SharedImageName n) - _ - (SharedImageBuildId bid) - _ - _) = - n ++ "_" ++ bid <.> sharedImageFileExtension +sharedImageFileName (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) _ _) = + n ++ "_" ++ bid <.> sharedImageFileExtension sharedImagesRootDirectory :: FilePath sharedImagesRootDirectory = "b9_shared_images" sharedImageFileExtension :: String sharedImageFileExtension = "b9si" + +-- | The internal image type to use as best guess when dealing with a 'From' +-- value. +sharedImageDefaultImageType :: ImageType +sharedImageDefaultImageType = QCow2 + +-- * Constructors for 'ImageTarget's + +-- | Use a 'QCow2' image with an 'Ext4' file system +transientCOWImage :: FilePath -> FilePath -> ImageTarget +transientCOWImage fileName mountPoint = + ImageTarget + Transient + (CopyOnWrite (Image fileName QCow2 Ext4)) + (MountPoint mountPoint) + +-- | Use a shared image +transientSharedImage :: SharedImageName -> FilePath -> ImageTarget +transientSharedImage (SharedImageName name) mountPoint = + ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) + +-- | Use a shared image +transientLocalImage :: FilePath -> FilePath -> ImageTarget +transientLocalImage name mountPoint = + ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) + +-- | Share a 'QCow2' image with 'Ext4' fs +shareCOWImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget +shareCOWImage srcFilename (SharedImageName destName) mountPoint = + ImageTarget + (Share destName QCow2 KeepSize) + (CopyOnWrite (Image srcFilename QCow2 Ext4)) + (MountPoint mountPoint) + +-- | Share an image based on a shared image +shareSharedImage :: SharedImageName + -> SharedImageName + -> FilePath + -> ImageTarget +shareSharedImage (SharedImageName srcName) (SharedImageName destName) mountPoint = + ImageTarget + (Share destName QCow2 KeepSize) + (From srcName KeepSize) + (MountPoint mountPoint) + +-- | Share a 'QCow2' image with 'Ext4' fs +shareLocalImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget +shareLocalImage srcName (SharedImageName destName) mountPoint = + ImageTarget + (Share destName QCow2 KeepSize) + (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) + (MountPoint mountPoint) + +-- | Export a 'QCow2' image with 'Ext4' fs +cowToliveInstallerImage :: String + -> FilePath + -> FilePath + -> FilePath + -> ImageTarget +cowToliveInstallerImage srcName destName outDir mountPoint = + ImageTarget + (LiveInstallerImage destName outDir KeepSize) + (CopyOnWrite (Image srcName QCow2 Ext4)) + (MountPoint mountPoint) + +-- | Export a 'QCow2' image file with 'Ext4' fs as +-- a local file +cowToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget +cowToLocalImage srcName destName mountPoint = + ImageTarget + (LocalFile (Image destName QCow2 Ext4) KeepSize) + (CopyOnWrite (Image srcName QCow2 Ext4)) + (MountPoint mountPoint) + +-- | Export a 'QCow2' image file with 'Ext4' fs as +-- a local file +localToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget +localToLocalImage srcName destName mountPoint = + ImageTarget + (LocalFile (Image destName QCow2 Ext4) KeepSize) + (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) + (MountPoint mountPoint) + +-- | Create a local image file from the contents of the first partition +-- of a local 'QCow2' image. +partition1ToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget +partition1ToLocalImage srcName destName mountPoint = + ImageTarget + (LocalFile (Image destName QCow2 Ext4) KeepSize) + (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize) + (MountPoint mountPoint) + +-- * 'ImageTarget' Transformations + +-- | Split any image target into two image targets, one for creating an intermediate shared image and one +-- from the intermediate shared image to the output image. +splitToIntermediateSharedImage :: ImageTarget + -> SharedImageName + -> (ImageTarget, ImageTarget) +splitToIntermediateSharedImage (ImageTarget dst src mnt) (SharedImageName intermediateName) = + (imgTargetShared, imgTargetExport) + where + imgTargetShared = ImageTarget intermediateTo src mnt + imgTargetExport = ImageTarget dst intermediateFrom mnt + intermediateTo = + Share + intermediateName + (fromMaybe + sharedImageDefaultImageType + (getImageSourceImageType src)) + KeepSize + intermediateFrom = From intermediateName KeepSize + +-- * 'Arbitrary' instances for quickcheck + +instance Arbitrary ImageTarget where + arbitrary = + ImageTarget <$> smaller arbitrary <*> smaller arbitrary <*> + smaller arbitrary + +instance Arbitrary ImageSource where + arbitrary = + oneof + [ EmptyImage "img-label" <$> smaller arbitrary <*> + smaller arbitrary <*> + smaller arbitrary + , CopyOnWrite <$> smaller arbitrary + , SourceImage <$> smaller arbitrary <*> smaller arbitrary <*> + smaller arbitrary + , From <$> arbitrarySharedImageName <*> smaller arbitrary] + +instance Arbitrary ImageDestination where + arbitrary = + oneof + [ Share <$> arbitrarySharedImageName <*> smaller arbitrary <*> + smaller arbitrary + , LiveInstallerImage "live-installer" "output-path" <$> + smaller arbitrary + , pure Transient] + +instance Arbitrary MountPoint where + arbitrary = elements [MountPoint "/mnt", NotMounted] + +instance Arbitrary ImageResize where + arbitrary = + oneof + [ ResizeImage <$> smaller arbitrary + , Resize <$> smaller arbitrary + , pure ShrinkToMinimum + , pure KeepSize] + +instance Arbitrary Partition where + arbitrary = oneof [Partition <$> elements [0, 1, 2], pure NoPT] + +instance Arbitrary Image where + arbitrary = + Image "img-file-name" <$> smaller arbitrary <*> smaller arbitrary + +instance Arbitrary FileSystem where + arbitrary = elements [Ext4] + +instance Arbitrary ImageType where + arbitrary = elements [Raw, QCow2, Vmdk] + +instance Arbitrary ImageSize where + arbitrary = ImageSize <$> smaller arbitrary <*> smaller arbitrary + +instance Arbitrary SizeUnit where + arbitrary = elements [B, KB, MB, GB] + +instance Arbitrary SharedImageName where + arbitrary = SharedImageName <$> arbitrarySharedImageName + +arbitrarySharedImageName :: Gen String +arbitrarySharedImageName = + elements [printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3]] 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 @@ -7,25 +7,41 @@ import Control.Monad import Test.QuickCheck -arbitraryEnv :: Arbitrary a => Gen [(String,a)] +arbitraryEnv + :: Arbitrary a + => Gen [(String, a)] arbitraryEnv = listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> arbitrary) halfSize :: Gen a -> Gen a halfSize g = sized (flip resize g . flip div 2) smaller :: Gen a -> Gen a -smaller g = sized (flip resize g . flip (-) 1 ) +smaller g = sized (flip resize g . max 0 . flip (-) 1) arbitraryFilePath :: Gen FilePath arbitraryFilePath = do - path <-join <$> listOf (elements ["/", "../", "./","etc/", "opt/","user/","var/","tmp/","doc/","share/","conf.d/"]) - prefix <- elements ["foo_", "", "alt_", "ssh-",""] - body <- elements ["www","passwd","cert","opnsfe","runtime"] - extension <- elements [".txt",".png",".ps",".erl",""] - return (path ++ prefix ++ body ++ extension) + path <- + join <$> + listOf + (elements + [ "/" + , "../" + , "./" + , "etc/" + , "opt/" + , "user/" + , "var/" + , "tmp/" + , "doc/" + , "share/" + , "conf.d/"]) + prefix <- elements ["foo_", "", "alt_", "ssh-", ""] + body <- elements ["www", "passwd", "cert", "opnsfe", "runtime"] + extension <- elements [".txt", ".png", ".ps", ".erl", ""] + return (path ++ prefix ++ body ++ extension) arbitraryLetter :: Gen Char -arbitraryLetter = oneof [arbitraryLetterUpper,arbitraryLetterLower] +arbitraryLetter = oneof [arbitraryLetterUpper, arbitraryLetterLower] arbitraryLetterUpper :: Gen Char arbitraryLetterUpper = elements ['A' .. 'Z'] diff --git a/src/tests/B9/ArtifactGeneratorImplSpec.hs b/src/tests/B9/ArtifactGeneratorImplSpec.hs --- a/src/tests/B9/ArtifactGeneratorImplSpec.hs +++ b/src/tests/B9/ArtifactGeneratorImplSpec.hs @@ -15,24 +15,24 @@ it "replaces '$...' variables in SourceImage Image file paths" $ let e = CGEnv [("variable","value")] [] - src = vmImagesArtifact "" [transientCOWImage "${variable}" ""] NoVmScript - expected = transientCOWImage "value" "" + src = vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript + expected = transientCOW "value" "" (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv in actual `shouldBe` expected it "replaces '$...' variables in SourceImage 'From' names" $ let e = CGEnv [("variable","value")] [] - src = vmImagesArtifact "" [transientSharedImage "${variable}" ""] NoVmScript - expected = transientSharedImage "value" "" + src = vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript + expected = transientShared "value" "" (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv in actual `shouldBe` expected it "replaces '$...' variables in the name of a shared image" $ let e = CGEnv [("variable","value")] [] - src = vmImagesArtifact "" [shareCOWImage "${variable}" ""] NoVmScript - expected = shareCOWImage "value" "" + src = vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript + expected = shareCOW "value" "" (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv in actual `shouldBe` expected @@ -85,20 +85,20 @@ (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv in actual `shouldBe` expected -transientCOWImage :: FilePath -> FilePath -> ImageTarget -transientCOWImage fileName mountPoint = +transientCOW :: FilePath -> FilePath -> ImageTarget +transientCOW fileName mountPoint = ImageTarget Transient (CopyOnWrite (Image fileName QCow2 Ext4)) (MountPoint mountPoint) -transientSharedImage :: FilePath -> FilePath -> ImageTarget -transientSharedImage name mountPoint = +transientShared :: FilePath -> FilePath -> ImageTarget +transientShared name mountPoint = ImageTarget Transient (From name KeepSize) (MountPoint mountPoint) -shareCOWImage :: FilePath -> FilePath -> ImageTarget -shareCOWImage destName mountPoint = +shareCOW :: FilePath -> FilePath -> ImageTarget +shareCOW destName mountPoint = ImageTarget (Share destName QCow2 KeepSize) (CopyOnWrite (Image "cowSource" QCow2 Ext4)) (MountPoint mountPoint) diff --git a/src/tests/B9/DiskImagesSpec.hs b/src/tests/B9/DiskImagesSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/DiskImagesSpec.hs @@ -0,0 +1,31 @@ +module B9.DiskImagesSpec (spec) where +import Test.Hspec +import Test.QuickCheck + +import B9.DiskImages + +spec :: Spec +spec = + describe "splitToIntermediateSharedImage" $ + do it "puts the original source into the intermediate target" $ + property + (\target name -> + itImageSource target == + itImageSource + (fst (splitToIntermediateSharedImage target name))) + it "puts the original destination into the export target" $ + property + (\target name -> + itImageDestination target == + itImageDestination + (snd (splitToIntermediateSharedImage target name))) + it + "puts the intermediate shared image name into both the \ + \intermediate and the export target" $ + property + (\target name -> + let (intermediateTarget,exportTarget) = + splitToIntermediateSharedImage target name + in imageDestinationSharedImageName + (itImageDestination intermediateTarget) == + imageSourceSharedImageName (itImageSource exportTarget))