diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -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 -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 -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 +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 +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 diff --git a/src/lib/B9/ArtifactGenerator.hs b/src/lib/B9/ArtifactGenerator.hs --- a/src/lib/B9/ArtifactGenerator.hs +++ b/src/lib/B9/ArtifactGenerator.hs @@ -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 = diff --git a/src/lib/B9/ArtifactGeneratorImpl.hs b/src/lib/B9/ArtifactGeneratorImpl.hs --- a/src/lib/B9/ArtifactGeneratorImpl.hs +++ b/src/lib/B9/ArtifactGeneratorImpl.hs @@ -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) + + + diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs --- a/src/lib/B9/DiskImageBuilder.hs +++ b/src/lib/B9/DiskImageBuilder.hs @@ -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)) diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs --- a/src/lib/B9/DiskImages.hs +++ b/src/lib/B9/DiskImages.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -2,5 +2,5 @@ packages: - '.' extra-deps: [] -resolver: lts-8.22 -pvp-bounds: lower +resolver: lts-9.4 +# pvp-bounds: lower