b9 0.5.10 → 0.5.13

raw patch · 10 files changed

+745/−373 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• .gitignore +1/−0
• b9.cabal +8/−1
• src/cli/Main.hs +179/−145
• src/lib/B9/ArtifactGenerator.hs +186/−151
• src/lib/B9/Content/Generator.hs +1/−1
• src/lib/B9/Content/YamlObject.hs +15/−14
• src/lib/B9/DiskImages.hs +288/−41
• src/lib/B9/QCUtil.hs +24/−8
• src/tests/B9/ArtifactGeneratorImplSpec.hs +12/−12
• src/tests/B9/DiskImagesSpec.hs +31/−0

@@ -15,3 +15,4 @@ /.idea/ *.iml +.stack-work

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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]]

@@ -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']

@@ -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)

@@ -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))