b9 0.4.1 → 0.5.2

raw patch · 11 files changed

+159/−167 lines, 11 filesdep +freedep ~ConfigFiledep ~asyncdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: free

Dependency ranges changed: ConfigFile, async, base, binary, bytestring, conduit, conduit-extra, directory, filepath, mtl, old-locale, optparse-applicative, parsec, process, random, syb, text, time, transformers, vector

API changes (from Hackage documentation)

Files

• .gitignore +0/−1
• b9.cabal +27/−26
• build_and_test.sh +1/−0
• installDeps.sh +0/−21
• prepare_release.sh +2/−1
• run.sh +0/−13
• src/lib/B9/ArtifactGeneratorImpl.hs +99/−79
• src/lib/B9/B9Monad.hs +1/−1
• src/lib/B9/ConfigUtils.hs +18/−16
• src/lib/B9/Content/ErlTerms.hs +9/−7
• src/lib/B9/LibVirtLXC.hs +2/−2

@@ -6,7 +6,6 @@ /BUILD-* /dist /OUT-/cabal.config  /.cabal-sandbox/ /cabal.sandbox.config

@@ -1,5 +1,5 @@ name:                b9-version:             0.4.1+version:             0.5.2  synopsis:            A tool and library for building virtual machine images. @@ -48,8 +48,8 @@ copyright:           2015 Sven Heyll <svh@posteo.de> category:            Development build-type:          Simple-extra-source-files:  README.md, build_and_run.sh, build_and_test.sh, build_haddock.sh, installDeps.sh,-                     run.sh, LICENSE, TODO.org, Setup.hs, b9.cabal, .gitignore, prepare_release.sh, .travis.yml, CONTRIBUTORS+extra-source-files:  README.md, build_and_run.sh, build_and_test.sh, build_haddock.sh,+                     LICENSE, TODO.org, Setup.hs, b9.cabal, .gitignore, prepare_release.sh, .travis.yml, CONTRIBUTORS cabal-version:       >=1.10  source-repository head@@ -84,34 +84,35 @@                    , B9.QCUtil   other-modules:   Paths_b9   -- other-extensions:-  build-depends:     ConfigFile >= 1.1.3 && <1.2+  build-depends:     ConfigFile                    , QuickCheck                    , aeson-                   , async >=2.0.1 && <2.1-                   , base >=4.6 && <4.8-                   , binary >=0.7 && <0.8-                   , bytestring >=0.10 && <0.11-                   , conduit >=1.2 && <1.3-                   , conduit-extra >=1.1 && <1.2-                   , directory >=1.2 && <1.3-                   , filepath >=1.3 && <1.4-                   , mtl >=2.1 && <2.2-                   , old-locale >=1.0 && <1.1-                   , parsec >= 3.1.8+                   , async+                   , base >= 4.7 && < 5+                   , binary+                   , bytestring+                   , conduit+                   , conduit-extra+                   , directory+                   , filepath+                   , mtl+                   , old-locale+                   , parsec                    , pretty-show                    , pretty-                   , process >=1.2 && <1.3-                   , random >=1.0 && <1.2+                   , process+                   , random                    , semigroups-                   , syb >= 0.4.4 && <0.5+                   , syb                    , template-                   , text >= 1.2.0.4-                   , time >=1.4 && <1.5-                   , transformers >=0.3 && <0.4+                   , text+                   , time+                   , transformers                    , unordered-containers-                   , vector >= 0.10.12.2+                   , vector                    , yaml                    , bifunctors+                   , free   default-extensions: TupleSections                     , GeneralizedNewtypeDeriving                     , DeriveDataTypeable@@ -128,9 +129,9 @@   -- other-modules:   -- other-extensions:   build-depends:     b9-                   , base >=4.6 && <4.8-                   , bytestring >=0.10 && <0.11-                   , optparse-applicative >= 0.11.0.1+                   , base >= 4.7 && < 5+                   , bytestring+                   , optparse-applicative   hs-source-dirs:    src/cli   default-language:  Haskell2010   ghc-options:       -O3 -threaded -with-rtsopts=-N -Wall -Wall@@ -146,7 +147,7 @@                    , B9.Content.ErlangPropListSpec                    , B9.Content.YamlObjectSpec                    , B9.ArtifactGeneratorImplSpec-  build-depends:     base >=4.6 && <4.8+  build-depends:     base >= 4.7 && < 5                    , b9                    , hspec                    , hspec-expectations

@@ -7,6 +7,7 @@  PATH="$(pwd)/.cabal-sandbox/bin:$PATH" +cabal install -j --enable-tests --dependencies-only cabal configure --enable-tests --disable-optimization cabal build ./dist/build/spec/spec

@@ -1,21 +0,0 @@-#!/bin/bash-#-# Install the latest stackage lts snapshot, run cabal clean/update and-# initialize the cabal sandbox.-#-set -e--PATH="$(pwd)/.cabal-sandbox/bin:$PATH"--cabal clean -v-cabal sandbox delete -v || echo "IGNORING"--rm -f cabal.config-wget http://www.stackage.org/lts/cabal.config--cabal update -v-cabal sandbox -v init--cabal install happy alex haddock--cabal install -v --only-dependencies --enable-tests -j

@@ -11,7 +11,8 @@  PATH="$(pwd)/.cabal-sandbox/bin:$PATH" -./installDeps.sh ./build_and_test.sh ./build_haddock.sh cabal check+cabal sdist+

@@ -1,13 +0,0 @@-#!/bin/sh--# Execute 'b9', if necessary compile it.--set -e--PATH="$(pwd)/.cabal-sandbox/bin:$PATH"--if [[ ! -x .cabal-sandbox/bin/b9c ]]; then-    cabal install-fi--.cabal-sandbox/bin/b9c  $@

@@ -39,22 +39,31 @@   b9cfgEnvVars <- envVars <$> getConfig   buildId <- getBuildId   buildDate <- getBuildDate+  case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of+    Left err -> error err+    Right is -> createAssembledArtifacts is++-- | Evaluate an 'ArtifactGenerator' into a list of low-level build instructions+-- that can be built with 'createAssembledArtifacts'.+evalArtifactGenerator :: String+                      -> String+                      -> BuildVariables+                      -> ArtifactGenerator+                      -> Either String [InstanceGenerator [SourceGenerator]]+evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen =   let ag = parseArtifactGenerator artGen-      e = CGEnv-            ((buildDateKey, buildDate):(buildIdKey, buildId):b9cfgEnvVars)-            []-  case execCGParser ag e of+      e = CGEnv ((buildDateKey, buildDate) : (buildIdKey, buildId) : b9cfgEnvVars) []+  in case execCGParser ag e of     Left (CGError err) ->-      error (printf "error parsing: %s: %s" (ppShow artGen)  err)+      Left (printf "error parsing: %s: %s" (ppShow artGen) err)     Right igs ->       case execIGEnv `mapM` igs of-        Left err ->-          error (printf "Failed to parse:\n%s\nError: %s"-                                   (ppShow artGen)-                                   err)-        Right is ->-          createAssembledArtifacts is+       Left err ->+         Left (printf "Failed to parse:\n%s\nError: %s" (ppShow artGen) err)+       Right is ->+         Right is +-- | Parse an artifacto generator inside a 'CGParser' monad. parseArtifactGenerator :: ArtifactGenerator -> CGParser () parseArtifactGenerator g =   case g of@@ -66,66 +75,72 @@       withXBindings bs (mapM_ parseArtifactGenerator gs)     EachT keySet valueSets gs -> do       allBindings <- eachBindingSetT g keySet valueSets-      mapM_ ($ mapM_ parseArtifactGenerator gs)-            (withBindings <$> allBindings)+      mapM_ ($ mapM_ parseArtifactGenerator gs) (withBindings <$> allBindings)     Each kvs gs -> do       allBindings <- eachBindingSet g kvs-      mapM_ ($ mapM_ parseArtifactGenerator gs)-             (withBindings <$> allBindings)+      mapM_ ($ mapM_ parseArtifactGenerator gs) (withBindings <$> allBindings)     Artifact iid assembly ->       writeInstanceGenerator iid assembly     EmptyArtifact ->       return () +-- | Execute a 'CGParser' action in an environment that contains a list of+-- 'ArtifactSource's. withArtifactSources :: [ArtifactSource] -> CGParser () -> CGParser ()-withArtifactSources srcs = local (\ce -> ce {agSources = agSources ce ++ srcs})+withArtifactSources srcs = local (\ce -> ce { agSources = agSources ce ++ srcs })  withBindings :: [(String,String)] -> CGParser () -> CGParser () withBindings bs = local (addBindings bs)  addBindings :: [(String, String)] -> CGEnv -> CGEnv addBindings bs ce =-  let addBinding env (k,v) = nubBy ((==) `on` fst) ((k, subst env v):env)+  let addBinding env (k, v) = nubBy ((==) `on` fst) ((k, subst env v) : env)       newEnv = foldl addBinding (agEnv ce) bs   in ce { agEnv = newEnv }  withXBindings :: [(String,[String])] -> CGParser () -> CGParser () withXBindings bs cp = do   (flip local cp) `mapM_` (addBindings <$> (allXBindings bs))+   where-    allXBindings ((k,vs):rest) = [(k,v):c | v <- vs, c <- allXBindings rest]+    allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs+                                              , c <- allXBindings rest]     allXBindings [] = [[]]  eachBindingSetT :: ArtifactGenerator                 -> [String]                 -> [[String]]-                -> CGParser [[(String,String)]]+                -> CGParser [[(String, String)]] eachBindingSetT g vars valueSets =   if all ((== length vars) . length) valueSets-     then return (zip vars <$> valueSets)-     else (cgError (printf "Error in 'Each' binding during artifact \+    then return (zip vars <$> valueSets)+    else (cgError+            (printf+               "Error in 'Each' binding during artifact \                            \generation in:\n '%s'.\n\nThe variable list\n\                            \%s\n has %i entries, but this binding set\n%s\n\n\                            \has a different number of entries!\n"-                           (ppShow g)-                           (ppShow vars)-                           (length vars)-                           (ppShow (head (dropWhile ((== length vars) . length)-                                                    valueSets)))))+               (ppShow g)+               (ppShow vars)+               (length vars)+               (ppShow (head (dropWhile ((== length vars) . length) valueSets)))))  eachBindingSet :: ArtifactGenerator-                -> [(String,[String])]-                -> CGParser [[(String,String)]]+               -> [(String, [String])]+               -> CGParser [[(String, String)]] eachBindingSet g kvs = do   checkInput   return bindingSets+   where-    bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs ]+    bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]     checkInput = when (1 /= (length $ nub $ length . snd <$> kvs))-                      (cgError (printf "Error in 'Each' binding: \n%s\n\+                   (cgError+                      (printf+                         "Error in 'Each' binding: \n%s\n\                                        \All value lists must have the same\                                        \length!"-                                       (ppShow g)))+                         (ppShow g)))   writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser ()@@ -138,19 +153,11 @@  -- | Monad for creating Instance generators. newtype CGParser a =-  CGParser { runCGParser :: WriterT [InstanceGenerator CGEnv]-                                   (ReaderT CGEnv-                                            (Either CGError))-                                   a-           }-  deriving ( Functor, Applicative, Monad-           , MonadReader CGEnv-           , MonadWriter [InstanceGenerator CGEnv]-           , MonadError CGError-           )+          CGParser+            { runCGParser :: WriterT [InstanceGenerator CGEnv] (ReaderT CGEnv (Either CGError)) a }+  deriving (Functor, Applicative, Monad, MonadReader CGEnv, MonadWriter [InstanceGenerator CGEnv], MonadError CGError) -data CGEnv = CGEnv { agEnv :: [(String, String)]-                   , agSources :: [ArtifactSource] }+data CGEnv = CGEnv { agEnv :: [(String, String)], agSources :: [ArtifactSource] }   deriving (Read, Show, Eq)  data InstanceGenerator e = IG InstanceId e ArtifactAssembly@@ -171,20 +178,22 @@           -> Either String (InstanceGenerator [SourceGenerator]) execIGEnv (IG iid (CGEnv env sources) assembly) = do   IG iid <$> sourceGens <*> pure (substAssembly env assembly)+   where     sourceGens = join <$> mapM (toSourceGen env) sources -substAssembly :: [(String,String)] -> ArtifactAssembly -> ArtifactAssembly+substAssembly :: [(String, String)] -> ArtifactAssembly -> ArtifactAssembly substAssembly env p = everywhere gsubst p-  where gsubst :: forall a. Data a => a -> a-        gsubst = mkT substAssembly_-                   `extT` (substImageTarget env)-                     `extT` (substVmScript env)+  where+    gsubst :: Data a => a -> a+    gsubst = mkT substAssembly_+             `extT` (substImageTarget env)+             `extT` (substVmScript env) -        substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)-        substAssembly_ vm = vm+    substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)+    substAssembly_ vm = vm -        sub = subst env+    sub = subst env  toSourceGen :: [(String, String)]             -> ArtifactSource@@ -251,35 +260,38 @@   let toAbs = instanceDir </> to   ensureDir toAbs   result <- case sgSource of-               SGFiles froms -> do-                 sources <- mapM (sgReadSourceFile env) froms-                 return (mconcat sources)-               SGContent c -> do-                  withEnvironment env (render c)+              SGFiles froms -> do+                sources <- mapM (sgReadSourceFile env) froms+                return (mconcat sources)+              SGContent c -> do+                withEnvironment env (render c)   traceL (printf "rendered: \n%s\n" (T.unpack (E.decodeUtf8 result)))   liftIO (B.writeFile toAbs result)   sgChangePerm toAbs p  -sgReadSourceFile :: [(String,String)] -> SourceFile -> B9 B.ByteString+sgReadSourceFile :: [(String, String)] -> SourceFile -> B9 B.ByteString sgReadSourceFile env = withEnvironment env . readTemplateFile  sgChangePerm :: FilePath -> SGPerm -> B9 () sgChangePerm _ KeepPerm = return ()-sgChangePerm f (SGSetPerm (o,g,a)) = cmd (printf "chmod 0%i%i%i '%s'" o g a f)+sgChangePerm f (SGSetPerm (o, g, a)) = cmd (printf "chmod 0%i%i%i '%s'" o g a f)  -- | Internal data type simplifying the rather complex source generation by --   bioling down 'ArtifactSource's to a flat list of uniform 'SourceGenerator's.-data SourceGenerator = SGConcat [(String,String)] SGSource SGPerm FilePath+data SourceGenerator = SGConcat [(String, String)] SGSource SGPerm FilePath   deriving (Read, Show, Eq) -data SGSource = SGFiles [SourceFile] | SGContent Content+data SGSource = SGFiles [SourceFile]+              | SGContent Content   deriving (Read, Show, Eq) -data SGType = SGT | SGF+data SGType = SGT+            | SGF   deriving (Read, Show, Typeable, Data, Eq) -data SGPerm = SGSetPerm (Int,Int,Int) | KeepPerm+data SGPerm = SGSetPerm (Int, Int, Int)+            | KeepPerm   deriving (Read, Show, Typeable, Data, Eq)  @@ -287,19 +299,22 @@ sgGetFroms (SGConcat _ (SGFiles fs) _ _) = fs sgGetFroms _ = [] -setSGPerm :: Int -> Int -> Int -> SourceGenerator+setSGPerm :: Int+          -> Int+          -> Int+          -> SourceGenerator           -> Either String SourceGenerator setSGPerm o g a (SGConcat env from KeepPerm dest) =-  Right (SGConcat env from (SGSetPerm (o,g,a)) dest)+  Right (SGConcat env from (SGSetPerm (o, g, a)) dest) setSGPerm o g a sg   | o < 0 || o > 7 =-    Left (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))+      Left (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))   | g < 0 || g > 7 =-    Left (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))+      Left (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))   | a < 0 || a > 7 =-    Left (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))+      Left (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))   | otherwise =-   Left (printf "Permission for source already defined:\n %s" (ppShow sg))+      Left (printf "Permission for source already defined:\n %s" (ppShow sg))  setSGFromDirectory :: FilePath -> SourceGenerator -> SourceGenerator setSGFromDirectory fromDir (SGConcat e (SGFiles fs) p d) =@@ -324,6 +339,7 @@   return [VmImagesTarget] createTarget _ instanceDir (CloudInit types outPath) = do   mapM create_ types+   where     create_ CI_DIR = do       let ciDir = outPath@@ -331,11 +347,12 @@       dbgL (printf "creating directory '%s'" ciDir)       files <- getDirectoryFiles instanceDir       traceL (printf "copying files: %s" (show files))-      liftIO (mapM_-                (\(f,t) -> do-                   ensureDir t-                   copyFile f t)-                (((instanceDir </>) &&& (ciDir </>)) <$> files))+      liftIO+        (mapM_+           (\(f, t) -> do+              ensureDir t+              copyFile f t)+           (((instanceDir </>) &&& (ciDir </>)) <$> files))       infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))       return (CloudInitTarget CI_DIR ciDir) @@ -346,13 +363,15 @@       ensureDir tmpFile       dbgL (printf "creating cloud init iso temp image '%s',\                    \ destination file: '%s" tmpFile isoFile)-      cmd (printf "genisoimage\+      cmd+        (printf+           "genisoimage\                   \ -output '%s'\                   \ -volid cidata\                   \ -rock\                   \ -d '%s' 2>&1"-                  tmpFile-                  instanceDir)+           tmpFile+           instanceDir)       dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)       ensureDir isoFile       liftIO (copyFile tmpFile isoFile)@@ -369,9 +388,10 @@       traceL (printf "adding '%s'" (show files))       cmd (printf "truncate --size 2M '%s'" tmpFile)       cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)-      cmd (intercalate " " ((printf "mcopy -oi '%s' " tmpFile)-                            : (printf "'%s'" <$> files))-           ++ " ::")+      cmd+        (intercalate " " ((printf "mcopy -oi '%s' " tmpFile)+                          : (printf "'%s'" <$> files))+         ++ " ::")       dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)       ensureDir vfatFile       liftIO (copyFile tmpFile vfatFile)

@@ -27,7 +27,7 @@ import           System.Directory import           System.Exit import           System.FilePath-import           System.Locale ( defaultTimeLocale )+-- import qualified System.Locale ( defaultTimeLocale ) import           System.Random ( randomIO ) import           Text.Printf import           Control.Concurrent.Async (Concurrently (..))

@@ -47,7 +47,7 @@                 | InHomeDir FilePath                 | InB9UserDir FilePath                 | InTempDir FilePath-                  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data)  resolve :: MonadIO m => SystemPath -> m FilePath resolve (Path p) = return p@@ -84,17 +84,18 @@ consult f = liftIO $ do   c <- readFile f   case readEither c of-   Left e ->-     throwIO $ ReaderException f e-   Right a ->-     return a+    Left e ->+      throwIO $ ReaderException f e+    Right a ->+      return a  maybeConsult :: (MonadIO m, Read a) => Maybe FilePath -> a -> m a maybeConsult Nothing defaultArg = return defaultArg maybeConsult (Just f) defaultArg = liftIO $ do   exists <- doesFileExist f   if exists-    then do consult f+    then do+      consult f     else return defaultArg  maybeConsultSystemPath :: (MonadIO m, Read a) => Maybe SystemPath -> a -> m a@@ -103,7 +104,8 @@   f' <- resolve f   exists <- doesFileExist f'   if exists-    then do consult f'+    then do+      consult f'     else return defaultArg  data IniFileException = IniFileException FilePath CPError@@ -115,8 +117,8 @@   cfgFile <- resolve cfgFile'   cp' <- liftIO $ readfile emptyCP cfgFile   case cp' of-     Left e -> liftIO $ throwIO (IniFileException cfgFile e)-     Right cp -> return cp+    Left e   -> liftIO $ throwIO (IniFileException cfgFile e)+    Right cp -> return cp  getOption :: (Get_C a, Monoid a) => ConfigParser -> SectionSpec -> OptionSpec -> a getOption cp sec key = either (const mempty) id $ get cp sec key@@ -139,10 +141,10 @@   randomUUID :: MonadIO m => m UUID-randomUUID = liftIO (UUID <$> ((,,,,,)-                               <$> randomIO-                               <*> randomIO-                               <*> randomIO-                               <*> randomIO-                               <*> randomIO-                               <*> randomIO))+randomUUID = liftIO+               (UUID <$> ((,,,,,) <$> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO))

@@ -106,25 +106,27 @@                     ,sized aErlTuple                     ]     where+      decrSize 0 = resize 0+      decrSize n = resize (n - 1)       aErlString n =-        ErlString <$> resize (n-1) (listOf (choose (toEnum 0,toEnum 255)))+        ErlString <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))       aErlFloat n = do-        f <- resize (n-1) arbitrary :: Gen Float+        f <- decrSize n arbitrary :: Gen Float         let d = fromRational (toRational f)         return (ErlFloat d)       aErlNatural n =-        ErlNatural <$> resize (n-1) arbitrary+        ErlNatural <$> decrSize n arbitrary       aErlChar n =-        ErlChar <$> resize (n-1) (choose (toEnum 0, toEnum 255))+        ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))       aErlAtomUnquoted n = do         f <- choose ('a','z')-        rest <- resize (n-1) aErlNameString+        rest <- decrSize n aErlNameString         return (ErlAtom (f:rest))       aErlAtomQuoted n = do-        cs <- resize (n-1) aParsableErlString+        cs <- decrSize n aParsableErlString         return (ErlAtom ("'" ++ cs ++ "'"))       aErlBinary n =-        ErlBinary <$> resize (n-1) (listOf (choose (toEnum 0,toEnum 255)))+        ErlBinary <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))       aParsableErlString = oneof [aErlNameString                                  ,aErlEscapedCharString                                  ,aErlControlCharString

@@ -49,8 +49,8 @@      execute (Context scriptDirHost uuid domainFile cfg) = do       let virsh = virshCommand cfg-      cmd $ printf "%s create '%s'" virsh domainFile-      cmd $ printf "%s console %U" virsh uuid+      cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile+      -- cmd $ printf "%s console %U" virsh uuid       checkSuccessMarker scriptDirHost      checkSuccessMarker scriptDirHost =