b9 0.5.32 → 0.5.34
raw patch · 6 files changed
+489/−410 lines, 6 filesdep ~ConfigFiledep ~aesondep ~async
Dependency ranges changed: ConfigFile, aeson, async, b9, bifunctors, binary, bytestring, conduit, conduit-extra, directory, filepath, free, hashable, hspec, hspec-expectations, mtl, optparse-applicative, parallel, parsec, pretty, pretty-show, process, semigroups, template, text, time, transformers, unordered-containers, vector, yaml
Files
- b9.cabal +207/−170
- src/lib/B9/ArtifactGenerator.hs +32/−13
- src/lib/B9/ArtifactGeneratorImpl.hs +229/−214
- src/lib/B9/DiskImageBuilder.hs +18/−10
- src/lib/B9/DiskImages.hs +1/−1
- stack.yaml +2/−2
b9.cabal view
@@ -1,178 +1,215 @@-name: b9-version: 0.5.32-cabal-version: >=1.22-build-type: Simple-license: MIT-license-file: LICENSE-copyright: 2015, 2016 Sven Heyll <svh@posteo.de>-maintainer: svh@posteo.de-homepage: https://github.com/sheyll/b9-vm-image-builder-bug-reports: https://github.com/sheyll/b9-vm-image-builder/issues-synopsis: A tool and library for building virtual machine images.-description:- Build virtual machine images for vm-deployments; resize,- un-partition, create from scratch or convert disk image- files in a variety of formats; assemble and generate all- associated files from templates and regular files.- VM images can further be modifed through scripts, which are- executed in LXC containers into which the vm-images as well- as arbitrary directories from the host are mounted.- All assembled files can also be accessed by vm build- scripts through a special directory mounted in the build- container, and/or can be written to directories, ISO- or- VFAT-images.- The ISO/VFAT images that B9 creates are compatible to- 'cloud-init's 'NoCloud' data source;- B9 is also very well suited for compiling in a- containerized environment. For these applications, the- images can be marked as 'Transient' to indicate no further- interest in the VM-image itself, and B9 will discard them- after the build.- B9 will never over-write source files, not even large- vm-image files - there is no intended way to modify a- source vm-image file 'in-place'.- B9 operates in random build directories, which are- discarded when the build exists.-category: Development-author: Sven Heyll <svh@posteo.de>-extra-source-files:- README.md- build_and_test.sh- build_haddock.sh- LICENSE- TODO.org- Setup.hs- b9.cabal- .gitignore- prepare_release.sh- stack.yaml- stack-lts-5.14.yaml- .travis.yml- CONTRIBUTORS+name: b9+version: 0.5.34 +synopsis: A tool and library for building virtual machine images.++description: Build virtual machine images for vm-deployments; resize,+ un-partition, create from scratch or convert disk image+ files in a variety of formats; assemble and generate all+ associated files from templates and regular files.+++ VM images can further be modifed through scripts, which are+ executed in LXC containers into which the vm-images as well+ as arbitrary directories from the host are mounted.+++ All assembled files can also be accessed by vm build+ scripts through a special directory mounted in the build+ container, and/or can be written to directories, ISO- or+ VFAT-images.+++ The ISO/VFAT images that B9 creates are compatible to+ 'cloud-init's 'NoCloud' data source;+++ B9 is also very well suited for compiling in a+ containerized environment. For these applications, the+ images can be marked as 'Transient' to indicate no further+ interest in the VM-image itself, and B9 will discard them+ after the build.+++ B9 will never over-write source files, not even large+ vm-image files - there is no intended way to modify a+ source vm-image file 'in-place'.+++ B9 operates in random build directories, which are+ discarded when the build exists.++license: MIT+license-file: LICENSE+author: Sven Heyll <svh@posteo.de>+maintainer: svh@posteo.de+homepage: https://github.com/sheyll/b9-vm-image-builder+bug-reports: https://github.com/sheyll/b9-vm-image-builder/issues+copyright: 2015, 2016, 2017 Sven Heyll <svh@posteo.de>+category: Development+build-type: Simple+extra-source-files: README.md+ , build_and_test.sh+ , build_haddock.sh+ , LICENSE+ , TODO.org+ , Setup.hs+ , b9.cabal+ , .gitignore+ , prepare_release.sh+ , stack.yaml+ , stack-lts-5.14.yaml+ , .travis.yml+ , CONTRIBUTORS+cabal-version: >=1.22+ source-repository head- type: git- location: git://github.com/sheyll/b9-vm-image-builder.git+ type: git+ location: git://github.com/sheyll/b9-vm-image-builder.git library- - if (impl(ghc >=7.8.2) && impl(ghc <=7.10))- ghc-options: -fno-warn-amp- exposed-modules:- B9- B9.B9Monad- B9.B9Config- B9.Builder- B9.ConfigUtils- B9.ExecEnv- B9.DiskImages- B9.DiskImageBuilder- B9.ShellScript- B9.PartitionTable- B9.MBR- B9.LibVirtLXC- B9.Repository- B9.RepositoryIO- B9.ArtifactGenerator- B9.ArtifactGeneratorImpl- B9.Vm- B9.VmBuilder- B9.Content.ErlTerms- B9.Content.ErlangPropList- B9.Content.YamlObject- B9.Content.AST- B9.Content.Generator- B9.Content.StringTemplate- B9.QCUtil- B9.DSL- build-depends:- ConfigFile >=1.1.4,- QuickCheck >=2.5,- aeson >=1.0.2.1,- async >=2.1.1.1,- base >=4.8 && <5,- binary >=0.8.3.0,- bytestring >=0.10.8.1,- conduit >=1.2.11,- conduit-extra >=1.1.16,- directory >=1.3.0.0,- filepath >=1.4.1.1,- hashable >=1.2.6.1,- mtl >=2.2.1,- time >=1.6.0.1,- parallel >=3.2.1.1,- parsec >=3.1.11,- pretty-show >=1.6.13,- pretty >=1.1.3.3,- process >=1.4.3.0,- random >=1.1,- semigroups >=0.18.2,- syb >=0.6,- template >=0.2.0.10,- text >=1.2.2.1,- transformers >=0.5.2.0,- unordered-containers >=0.2.8.0,- vector >=0.11.0.0,- yaml >=0.8.23.1,- bifunctors >=5.4.2,- free >=4.12.4,- boxes >=0.1.4- default-language: Haskell2010- default-extensions: TupleSections GeneralizedNewtypeDeriving- DeriveDataTypeable DeriveGeneric RankNTypes FlexibleContexts GADTs- DataKinds KindSignatures TypeFamilies DeriveFunctor TemplateHaskell- StandaloneDeriving CPP- hs-source-dirs: src/lib- other-modules:- Paths_b9- ghc-options: -Wall -fwarn-unused-binds -fno-warn-unused-do-bind+ exposed-modules: B9+ , B9.B9Monad+ , B9.B9Config+ , B9.Builder+ , B9.ConfigUtils+ , B9.ExecEnv+ , B9.DiskImages+ , B9.DiskImageBuilder+ , B9.ShellScript+ , B9.PartitionTable+ , B9.MBR+ , B9.LibVirtLXC+ , B9.Repository+ , B9.RepositoryIO+ , B9.ArtifactGenerator+ , B9.ArtifactGeneratorImpl+ , B9.Vm+ , B9.VmBuilder+ , B9.Content.ErlTerms+ , B9.Content.ErlangPropList+ , B9.Content.YamlObject+ , B9.Content.AST+ , B9.Content.Generator+ , B9.Content.StringTemplate+ , B9.QCUtil+ , B9.DSL+ other-modules: Paths_b9+ -- other-extensions:+ build-depends: ConfigFile >= 1.1+ , QuickCheck >= 2.5+ , aeson >= 1.0+ , async >= 2.1+ , base >= 4.8 && < 5+ , binary >= 0.8.3+ , bytestring >= 0.10.8+ , conduit >= 1.2+ , conduit-extra >= 1.1+ , directory >= 1.3+ , filepath >= 1.4+ , hashable >= 1.2+ , mtl >= 2.2+ , time >= 1.6+ , parallel >= 3.2+ , parsec >= 3.2+ , pretty-show >= 1.6+ , pretty >= 1.1+ , process >= 1.4+ , random >= 1.1+ , semigroups >= 0.18+ , syb >= 0.6+ , template >= 0.2+ , text >= 1.2+ , transformers >= 0.5+ , unordered-containers >= 0.2.8+ , vector >= 0.11+ , yaml >= 0.8+ , bifunctors >= 5.4+ , free >= 4.12+ , boxes >= 0.1.4+ default-extensions: TupleSections+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ , DeriveGeneric+ , RankNTypes+ , FlexibleContexts+ , GADTs+ , DataKinds+ , KindSignatures+ , TypeFamilies+ , DeriveFunctor+ , TemplateHaskell+ , StandaloneDeriving+ , CPP+ hs-source-dirs: src/lib+ default-language: Haskell2010+ ghc-options: -Wall+ -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- - if (impl(ghc >=7.8.2) && impl(ghc <=7.10))- ghc-options: -fno-warn-amp- main-is: Main.hs- build-depends:- b9 >=0.5.32,- base >=4.8 && <5,- directory >=1.3.0.0,- bytestring >=0.10.8.1,- optparse-applicative >=0.13.2.0- default-language: Haskell2010- default-extensions: TupleSections GeneralizedNewtypeDeriving- DeriveDataTypeable RankNTypes FlexibleContexts GADTs DataKinds- KindSignatures TypeFamilies DeriveFunctor TemplateHaskell CPP- hs-source-dirs: src/cli- ghc-options: -threaded -with-rtsopts=-N -Wall -fwarn-unused-binds -fno-warn-unused-do-bind+ main-is: Main.hs+ -- other-modules:+ -- other-extensions:+ build-depends: b9+ , base >= 4.8 && < 5+ , directory >= 1.3+ , bytestring >= 0.10+ , optparse-applicative >= 0.13+ hs-source-dirs: src/cli+ default-language: Haskell2010+ default-extensions: TupleSections+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ , RankNTypes+ , FlexibleContexts+ , GADTs+ , DataKinds+ , KindSignatures+ , TypeFamilies+ , DeriveFunctor+ , TemplateHaskell+ , CPP+ ghc-options: -threaded -with-rtsopts=-N -Wall+ -fwarn-unused-binds -fno-warn-unused-do-bind+ if impl(ghc >= 7.8.2) && impl(ghc <= 7.10)+ ghc-options: -fno-warn-amp test-suite spec- - if (impl(ghc >=7.8.2) && impl(ghc <=7.10))- ghc-options: -fno-warn-amp -fno-warn-unused-do-bind- type: exitcode-stdio-1.0- main-is: Spec.hs- build-depends:- base >=4.8 && <5,- b9 >=0.5.32,- hspec >=2.4.3,- hspec-expectations >=0.8.2,- QuickCheck >=2.5,- aeson >=1.0.2.1,- yaml >=0.8.23.1,- vector >=0.11.0.0,- unordered-containers >=0.2.8.0,- bytestring >=0.10.8.1,- text >=1.2.2.1,- semigroups >=0.18.2- default-language: Haskell2010- default-extensions: TupleSections GeneralizedNewtypeDeriving- DeriveDataTypeable RankNTypes FlexibleContexts GADTs DataKinds- KindSignatures TypeFamilies DeriveFunctor TemplateHaskell CPP- hs-source-dirs: src/tests- other-modules:- B9.Content.ErlTermsSpec- B9.Content.ErlangPropListSpec- B9.Content.YamlObjectSpec- B9.ArtifactGeneratorImplSpec- B9.DiskImagesSpec- ghc-options: -Wall+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: src/tests+ default-language: Haskell2010+ main-is: Spec.hs+ other-modules: B9.Content.ErlTermsSpec+ , B9.Content.ErlangPropListSpec+ , B9.Content.YamlObjectSpec+ , B9.ArtifactGeneratorImplSpec+ , B9.DiskImagesSpec+ build-depends: base >= 4.8 && < 5+ , b9+ , hspec + , hspec-expectations+ , QuickCheck >= 2.5+ , aeson >= 1.0+ , yaml >= 0.8+ , vector >= 0.11+ , unordered-containers >= 0.2+ , bytestring >= 0.10+ , text >= 1.2+ , semigroups+ default-extensions: TupleSections+ , GeneralizedNewtypeDeriving+ , DeriveDataTypeable+ , RankNTypes+ , FlexibleContexts+ , GADTs+ , DataKinds+ , KindSignatures+ , TypeFamilies+ , DeriveFunctor+ , TemplateHaskell+ , CPP+ if impl(ghc >= 7.8.2) && impl(ghc <= 7.10)+ ghc-options: -fno-warn-amp -fno-warn-unused-do-bind
src/lib/B9/ArtifactGenerator.hs view
@@ -6,8 +6,8 @@ module B9.ArtifactGenerator (ArtifactGenerator(..), ArtifactSource(..), InstanceId(..), ArtifactTarget(..), CloudInitType(..), ArtifactAssembly(..),- AssembledArtifact(..), instanceIdKey, buildIdKey, buildDateKey,- getAssemblyOutputFiles)+ AssembledArtifact(..), AssemblyOutput(..), instanceIdKey, buildIdKey, buildDateKey,+ getAssemblyOutput, getArtifactSourceFiles) where import Control.Parallel.Strategies@@ -173,6 +173,19 @@ instance Binary ArtifactSource instance NFData ArtifactSource +-- | Return all source files generated by an 'ArtifactSource'.+getArtifactSourceFiles :: ArtifactSource -> [FilePath]+getArtifactSourceFiles (Concatenation f _) = [f]+getArtifactSourceFiles (FromContent f _) = [f]+getArtifactSourceFiles (FromFile f _) = [f]+getArtifactSourceFiles (IntoDirectory pd as) =+ (pd</>) <$> (as >>= getArtifactSourceFiles)+getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles+getArtifactSourceFiles (SetPermissions _ _ _ as) =+ as >>= getArtifactSourceFiles+++ -- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all -- instances IDs are unique. newtype InstanceId =@@ -250,18 +263,23 @@ instance Binary CloudInitType instance NFData CloudInitType +-- | The output of an 'ArtifactAssembly' is either a set of generated files,+-- or it might be a directory that contains the artifacts sources.+data AssemblyOutput =+ AssemblyGeneratesOutputFiles [FilePath]+ | AssemblyCopiesSourcesToDirectory FilePath+ deriving (Read,Show,Typeable,Data,Eq,Generic)+ -- | Return the files that the artifact assembly consist of.-getAssemblyOutputFiles :: ArtifactAssembly -> [FilePath]-getAssemblyOutputFiles (VmImages ts _) =- concatMap getImageDestinationOutputFiles ts-getAssemblyOutputFiles (CloudInit ts o) =- concatMap (getCloudInitOutputFiles o) ts- where- getCloudInitOutputFiles baseName t- | t == CI_ISO = [baseName <.> "iso"]- | t == CI_VFAT = [baseName <.> "vfat"]- | t == CI_DIR = [baseName </> "meta-data", baseName </> "user-data"]- | otherwise = []+getAssemblyOutput :: ArtifactAssembly -> [AssemblyOutput]+getAssemblyOutput (VmImages ts _) =+ AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts+getAssemblyOutput (CloudInit ts o) = getCloudInitOutputFiles o <$> ts+ where+ getCloudInitOutputFiles baseName t = case t of+ CI_ISO -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]+ CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]+ CI_DIR -> AssemblyCopiesSourcesToDirectory baseName -- * QuickCheck instances@@ -275,6 +293,7 @@ , halfSize arbitraryEach <*> halfSize arbitrary , Artifact <$> smaller arbitrary <*> smaller arbitrary , pure EmptyArtifact]+ arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator) arbitraryEachT =
src/lib/B9/ArtifactGeneratorImpl.hs view
@@ -36,121 +36,128 @@ -- by the ArtifactGenerator. This excludes 'Shared' and Transient image targets. getArtifactOutputFiles :: ArtifactGenerator -> Either String [FilePath] getArtifactOutputFiles g =- concatMap getAssemblyOutputFiles- <$> map takeAssembly- <$> evalArtifactGenerator undefined undefined [] g+ concatMap getOutputs <$> evalArtifactGenerator undefined undefined [] g where- takeAssembly (IG _ _ a) = a+ getOutputs (IG _ sgs a) =+ let+ toOutFile (AssemblyGeneratesOutputFiles fs) = fs+ toOutFile (AssemblyCopiesSourcesToDirectory pd) =+ let sourceFiles = sourceGeneratorOutputFile <$> sgs+ in (pd </>) <$> sourceFiles + in getAssemblyOutput a >>= toOutFile+ -- | Run an artifact generator to produce the artifacts. assemble :: ArtifactGenerator -> B9 [AssembledArtifact] assemble artGen = do b9cfgEnvVars <- envVars <$> getConfig- buildId <- getBuildId- buildDate <- getBuildDate+ buildId <- getBuildId+ buildDate <- getBuildDate case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of- Left err -> error err- Right is -> createAssembledArtifacts is+ 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+ :: String+ -> String+ -> BuildVariables+ -> ArtifactGenerator+ -> Either String [InstanceGenerator [SourceGenerator]] evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen =- let ag = parseArtifactGenerator artGen- e = CGEnv ((buildDateKey, buildDate) : (buildIdKey, buildId) : b9cfgEnvVars) []- in case execCGParser ag e of- Left (CGError err) ->- Left (printf "error parsing: %s: %s" (ppShow artGen) err)- Right igs ->- case execIGEnv `mapM` igs of- Left err ->- Left (printf "Failed to parse:\n%s\nError: %s" (ppShow artGen) err)- Right is ->- Right is+ let+ ag = parseArtifactGenerator artGen+ e = CGEnv+ ((buildDateKey, buildDate) : (buildIdKey, buildId) : b9cfgEnvVars)+ []+ in+ case execCGParser ag e of+ Left (CGError err) ->+ Left (printf "error parsing: %s: %s" (ppShow artGen) err)+ Right igs -> case execIGEnv `mapM` igs of+ 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- Sources srcs gs ->- withArtifactSources srcs (mapM_ parseArtifactGenerator gs)- Let bs gs ->- withBindings bs (mapM_ parseArtifactGenerator gs)- LetX bs gs ->- withXBindings bs (mapM_ parseArtifactGenerator gs)- EachT keySet valueSets gs -> do- allBindings <- eachBindingSetT g keySet valueSets- mapM_ ($ mapM_ parseArtifactGenerator gs) (withBindings <$> allBindings)- Each kvs gs -> do- allBindings <- eachBindingSet g kvs- mapM_ ($ mapM_ parseArtifactGenerator gs) (withBindings <$> allBindings)- Artifact iid assembly ->- writeInstanceGenerator iid assembly- EmptyArtifact ->- return ()+parseArtifactGenerator g = case g of+ Sources srcs gs -> withArtifactSources srcs (mapM_ parseArtifactGenerator gs)+ Let bs gs -> withBindings bs (mapM_ parseArtifactGenerator gs)+ LetX bs gs -> withXBindings bs (mapM_ parseArtifactGenerator gs)+ EachT keySet valueSets gs -> do+ allBindings <- eachBindingSetT g keySet valueSets+ sequence_+ (flip withBindings (mapM_ parseArtifactGenerator gs) <$> allBindings)+ Each kvs gs -> do+ allBindings <- eachBindingSet g kvs+ sequence_ $ do+ b <- allBindings+ return (withBindings b (mapM_ parseArtifactGenerator gs))+ 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 :: [(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) newEnv = foldl addBinding (agEnv ce) bs- in ce { agEnv = newEnv }+ in ce { agEnv = newEnv } -withXBindings :: [(String,[String])] -> CGParser () -> CGParser ()-withXBindings bs cp = (`local` cp) `mapM_` (addBindings <$> allXBindings bs)- where- allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs- , c <- allXBindings rest]- allXBindings [] = [[]]+withXBindings :: [(String, [String])] -> CGParser () -> CGParser ()+withXBindings bs cp = (`local`cp) `mapM_` (addBindings <$> allXBindings bs)+ where+ allXBindings ((k, vs):rest) =+ [ (k, v) : c | v <- vs, c <- allXBindings rest ]+ allXBindings [] = [[]] -eachBindingSetT :: ArtifactGenerator- -> [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 generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"- (ppShow g)- (ppShow vars)- (length vars)- (ppShow (head (dropWhile ((== length vars) . length) valueSets))))+eachBindingSetT+ :: ArtifactGenerator+ -> [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 generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"+ (ppShow g)+ (ppShow vars)+ (length vars)+ (ppShow (head (dropWhile ((==length vars) . length) valueSets)))+ ) -eachBindingSet :: ArtifactGenerator- -> [(String, [String])]- -> CGParser [[(String, String)]]+eachBindingSet+ :: ArtifactGenerator -> [(String, [String])] -> CGParser [[(String, String)]] eachBindingSet g kvs = do- checkInput- return bindingSets- where- bindingSets = transpose [repeat k `zip` vs | (k,vs) <- kvs]- checkInput =- when- (1 /= length (nub $ length . snd <$> kvs))- (cgError- (printf- "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"- (ppShow g)))+ checkInput+ return bindingSets+ where+ bindingSets = transpose [ repeat k `zip` vs | (k, vs) <- kvs ]+ checkInput = when+ (1 /= length (nub $ length . snd <$> kvs))+ ( cgError+ ( printf+ "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"+ (ppShow g)+ )+ ) writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser () writeInstanceGenerator (IID iidStrT) assembly = do env@(CGEnv bindings _) <- ask iid <- either (throwError . CGError) (return . IID) (substE bindings iidStrT)- let env' = addBindings [(instanceIdKey, iidStr)] env+ let env' = addBindings [(instanceIdKey, iidStr)] env IID iidStr = iid tell [IG iid env' assembly] @@ -172,60 +179,57 @@ cgError :: String -> CGParser a cgError msg = throwError (CGError msg) -execCGParser :: CGParser ()- -> CGEnv- -> Either CGError [InstanceGenerator CGEnv]+execCGParser :: CGParser () -> CGEnv -> Either CGError [InstanceGenerator CGEnv] execCGParser = runReaderT . execWriterT . runCGParser -execIGEnv :: InstanceGenerator CGEnv- -> Either String (InstanceGenerator [SourceGenerator])-execIGEnv (IG iid (CGEnv env sources) assembly) = IG iid <$> sourceGens <*> pure (substAssembly env assembly)- where- sourceGens = join <$> mapM (toSourceGen env) sources+execIGEnv+ :: InstanceGenerator CGEnv+ -> Either String (InstanceGenerator [SourceGenerator])+execIGEnv (IG iid (CGEnv env sources) assembly) =+ IG iid <$> sourceGens <*> pure (substAssembly env assembly)+ where sourceGens = join <$> mapM (toSourceGen env) sources substAssembly :: [(String, String)] -> ArtifactAssembly -> ArtifactAssembly substAssembly env = everywhere gsubst- where- gsubst :: 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- -> Either String [SourceGenerator]-toSourceGen env src =- case src of- FromFile t (Source conv f) -> do- t' <- substE env t- f' <- substE env f- return [SGConcat env (SGFiles [Source conv f']) KeepPerm t']- FromContent t c -> do- t' <- substE env t- return [SGConcat env (SGContent c) KeepPerm t']- Concatenation t src' -> do- sgs <- join <$> mapM (toSourceGen env) src'- t' <- substE env t- let froms = join (sgGetFroms <$> sgs)- return [SGConcat env (SGFiles froms) KeepPerm t']- SetPermissions o g a src' -> do- sgs <- join <$> mapM (toSourceGen env) src'- mapM (setSGPerm o g a) sgs- FromDirectory fromDir src' -> do- sgs <- join <$> mapM (toSourceGen env) src'- fromDir' <- substE env fromDir- return (setSGFromDirectory fromDir' <$> sgs)- IntoDirectory toDir src' -> do- sgs <- join <$> mapM (toSourceGen env) src'- toDir' <- substE env toDir- return (setSGToDirectory toDir' <$> sgs)+toSourceGen+ :: [(String, String)] -> ArtifactSource -> Either String [SourceGenerator]+toSourceGen env src = case src of+ FromFile t (Source conv f) -> do+ t' <- substE env t+ f' <- substE env f+ return [SG env (SGFiles [Source conv f']) KeepPerm t']+ FromContent t c -> do+ t' <- substE env t+ return [SG env (SGContent c) KeepPerm t']+ Concatenation t src' -> do+ sgs <- join <$> mapM (toSourceGen env) src'+ t' <- substE env t+ let froms = join (sgGetFroms <$> sgs)+ return [SG env (SGFiles froms) KeepPerm t']+ SetPermissions o g a src' -> do+ sgs <- join <$> mapM (toSourceGen env) src'+ mapM (setSGPerm o g a) sgs+ FromDirectory fromDir src' -> do+ sgs <- join <$> mapM (toSourceGen env) src'+ fromDir' <- substE env fromDir+ return (setSGFromDirectory fromDir' <$> sgs)+ IntoDirectory toDir src' -> do+ sgs <- join <$> mapM (toSourceGen env) src'+ toDir' <- substE env toDir+ return (setSGToDirectory toDir' <$> sgs) -createAssembledArtifacts :: [InstanceGenerator [SourceGenerator]]- -> B9 [AssembledArtifact]+createAssembledArtifacts+ :: [InstanceGenerator [SourceGenerator]] -> B9 [AssembledArtifact] createAssembledArtifacts igs = do buildDir <- getBuildDir let outDir = buildDir </> "artifact-instances"@@ -233,9 +237,10 @@ generated <- generateSources outDir `mapM` igs createTargets `mapM` generated -generateSources :: FilePath- -> InstanceGenerator [SourceGenerator]- -> B9 (InstanceGenerator FilePath)+generateSources+ :: FilePath+ -> InstanceGenerator [SourceGenerator]+ -> B9 (InstanceGenerator FilePath) generateSources outDir (IG iid sgs assembly) = do uiid@(IID uiidStr) <- generateUniqueIID iid dbgL (printf "generating sources for %s" uiidStr)@@ -256,15 +261,14 @@ return (IID (printf "%s-%s" iid buildId)) generateSourceTo :: FilePath -> SourceGenerator -> B9 ()-generateSourceTo instanceDir (SGConcat env sgSource p to) = do+generateSourceTo instanceDir (SG env sgSource p to) = do let toAbs = instanceDir </> to ensureDir toAbs result <- case sgSource of- SGFiles froms -> do- sources <- mapM (sgReadSourceFile env) froms- return (mconcat sources)- SGContent c ->- withEnvironment env (render c)+ SGFiles froms -> do+ sources <- mapM (sgReadSourceFile env) froms+ return (mconcat sources)+ SGContent c -> withEnvironment env (render c) traceL (printf "rendered: \n%s\n" (T.unpack (E.decodeUtf8 result))) liftIO (B.writeFile toAbs result) sgChangePerm toAbs p@@ -275,117 +279,128 @@ 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 = SG [(String, String)] SGSource SGPerm FilePath deriving (Read, Show, Eq) +-- | Return the (internal-)output file of the source file that is generated.+sourceGeneratorOutputFile :: SourceGenerator -> FilePath+sourceGeneratorOutputFile (SG _ _ _ f) = f+ data SGSource = SGFiles [SourceFile] | SGContent Content deriving (Read, Show, Eq) -data SGType = SGT- | SGF- deriving (Read, Show, Typeable, Data, Eq)- data SGPerm = SGSetPerm (Int, Int, Int) | KeepPerm deriving (Read, Show, Typeable, Data, Eq) sgGetFroms :: SourceGenerator -> [SourceFile]-sgGetFroms (SGConcat _ (SGFiles fs) _ _) = fs-sgGetFroms _ = []+sgGetFroms (SG _ (SGFiles fs) _ _) = fs+sgGetFroms _ = [] -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)+setSGPerm+ :: Int -> Int -> Int -> SourceGenerator -> Either String SourceGenerator+setSGPerm o g a (SG env from KeepPerm dest) =+ Right (SG 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))- | g < 0 || g > 7 =- 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))- | otherwise =- Left (printf "Permission for source already defined:\n %s" (ppShow sg))+ | o < 0 || o > 7 = 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))+ | a < 0 || a > 7 = Left+ (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))+ | otherwise = Left+ (printf "Permission for source already defined:\n %s" (ppShow sg)) setSGFromDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGFromDirectory fromDir (SGConcat e (SGFiles fs) p d) =- SGConcat e (SGFiles (setSGFrom <$> fs)) p d- where- setSGFrom (Source t f) = Source t (fromDir </> f)+setSGFromDirectory fromDir (SG e (SGFiles fs) p d) = SG+ e+ (SGFiles (setSGFrom <$> fs))+ p+ d+ where setSGFrom (Source t f) = Source t (fromDir </> f) setSGFromDirectory _fromDir sg = sg setSGToDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGToDirectory toDir (SGConcat e fs p d) =- SGConcat e fs p (toDir </> d)+setSGToDirectory toDir (SG e fs p d) = SG e fs p (toDir </> d) -- | Create the actual target, either just a mountpoint, or an ISO or VFAT -- image.-createTarget :: InstanceId -> FilePath -> ArtifactAssembly -> B9 [ArtifactTarget]+createTarget+ :: InstanceId -> FilePath -> ArtifactAssembly -> B9 [ArtifactTarget] createTarget iid instanceDir (VmImages imageTargets vmScript) = do dbgL (printf "Creating VM-Images in '%s'" instanceDir) success <- buildWithVm iid imageTargets instanceDir vmScript- let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr+ let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr (IID iidStr) = iid unless success (errorL err_msg >> error err_msg) return [VmImagesTarget] createTarget _ instanceDir (CloudInit types outPath) = mapM create_ types- where- create_ CI_DIR = do- let ciDir = outPath- ensureDir (ciDir ++ "/")- 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))- infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))- return (CloudInitTarget CI_DIR ciDir)+ where+ create_ CI_DIR = do+ let ciDir = outPath+ ensureDir (ciDir ++ "/")+ 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)+ )+ infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))+ return (CloudInitTarget CI_DIR ciDir) - create_ CI_ISO = do- buildDir <- getBuildDir- let isoFile = outPath <.> "iso"- tmpFile = buildDir </> takeFileName isoFile- ensureDir tmpFile- dbgL (printf "creating cloud init iso temp image '%s', destination file: '%s" tmpFile isoFile)- cmd- (printf- "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"- tmpFile- instanceDir)- dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)- ensureDir isoFile- liftIO (copyFile tmpFile isoFile)- infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))- return (CloudInitTarget CI_ISO isoFile)+ create_ CI_ISO = do+ buildDir <- getBuildDir+ let isoFile = outPath <.> "iso"+ tmpFile = buildDir </> takeFileName isoFile+ ensureDir tmpFile+ dbgL+ ( printf+ "creating cloud init iso temp image '%s', destination file: '%s"+ tmpFile+ isoFile+ )+ cmd+ ( printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"+ tmpFile+ instanceDir+ )+ dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)+ ensureDir isoFile+ liftIO (copyFile tmpFile isoFile)+ infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))+ return (CloudInitTarget CI_ISO isoFile) - create_ CI_VFAT = do- buildDir <- getBuildDir- let vfatFile = outPath <.> "vfat"- tmpFile = buildDir </> takeFileName vfatFile- ensureDir tmpFile- files <- map (instanceDir </>) <$> getDirectoryFiles instanceDir- dbgL (printf "creating cloud init vfat image '%s'" tmpFile)- traceL (printf "adding '%s'" (show files))- cmd (printf "truncate --size 2M '%s'" tmpFile)- cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)- cmd- (unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))- ++ " ::")- dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)- ensureDir vfatFile- liftIO (copyFile tmpFile vfatFile)- infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))- return (CloudInitTarget CI_ISO vfatFile)+ create_ CI_VFAT = do+ buildDir <- getBuildDir+ let vfatFile = outPath <.> "vfat"+ tmpFile = buildDir </> takeFileName vfatFile+ ensureDir tmpFile+ files <- map (instanceDir</>) <$> getDirectoryFiles instanceDir+ dbgL (printf "creating cloud init vfat image '%s'" tmpFile)+ traceL (printf "adding '%s'" (show files))+ cmd (printf "truncate --size 2M '%s'" tmpFile)+ cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)+ cmd+ ( unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))+ ++ " ::"+ )+ dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)+ ensureDir vfatFile+ liftIO (copyFile tmpFile vfatFile)+ infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))+ return (CloudInitTarget CI_ISO vfatFile)+++
src/lib/B9/DiskImageBuilder.hs view
@@ -252,10 +252,14 @@ imgFile (toQemuSizeOptVal imgSize)) case (imgFmt, imgFs) of+ (Raw,Ext4_64) -> do+ let fsCmd = "mkfs.ext4"+ dbgL (printf "Creating file system %s" (show imgFs))+ cmd (printf "%s -F -L '%s' -O 64bit -q '%s'" fsCmd fsLabel imgFile) (Raw,Ext4) -> do let fsCmd = "mkfs.ext4" dbgL (printf "Creating file system %s" (show imgFs))- cmd (printf "%s -F -L '%s' -q '%s'" fsCmd fsLabel imgFile)+ cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile) (it,fs) -> error (printf@@ -277,21 +281,25 @@ -- | Resize an image, including the file system inside the image. resizeImage :: ImageResize -> Image -> B9 () resizeImage KeepSize _ = return ()-resizeImage (Resize newSize) (Image img Raw Ext4) = do- let sizeOpt = toQemuSizeOptVal newSize- dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)- cmd (printf "e2fsck -p '%s'" img)- cmd (printf "resize2fs -f '%s' %s" img sizeOpt)+resizeImage (Resize newSize) (Image img Raw fs)+ | fs == Ext4 || fs == Ext4_64+ = do+ let sizeOpt = toQemuSizeOptVal newSize+ dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)+ cmd (printf "e2fsck -p '%s'" img)+ cmd (printf "resize2fs -f '%s' %s" img sizeOpt) resizeImage (ResizeImage newSize) (Image img _ _) = do let sizeOpt = toQemuSizeOptVal newSize dbgL (printf "Resizing image to %s" sizeOpt) cmd (printf "qemu-img resize -q '%s' %s" img sizeOpt) -resizeImage ShrinkToMinimum (Image img Raw Ext4) = do- dbgL "Shrinking image to minimum size"- cmd (printf "e2fsck -p '%s'" img)- cmd (printf "resize2fs -f -M '%s'" img)+resizeImage ShrinkToMinimum (Image img Raw fs)+ | fs == Ext4 || fs == Ext4_64+ = do+ dbgL "Shrinking image to minimum size"+ cmd (printf "e2fsck -p '%s'" img)+ cmd (printf "resize2fs -f -M '%s'" img) resizeImage _ img = error (printf "Invalid image type or filesystem, cannot resize image: %s" (show img))
src/lib/B9/DiskImages.hs view
@@ -111,7 +111,7 @@ instance NFData ImageType -- | The file systems that b9 can use and convert.-data FileSystem = NoFileSystem | Ext4 | ISO9660 | VFAT+data FileSystem = NoFileSystem | Ext4 | Ext4_64 | ISO9660 | VFAT deriving (Eq,Show,Read,Typeable,Data,Generic) instance Hashable FileSystem
stack.yaml view
@@ -2,5 +2,5 @@ packages: - '.' extra-deps: []-resolver: lts-8.22-pvp-bounds: lower+resolver: lts-9.4+# pvp-bounds: lower