diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -6,7 +6,6 @@ /BUILD-* /dist /OUT -/cabal.config /.cabal-sandbox/ /cabal.sandbox.config diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -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 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 diff --git a/build_and_test.sh b/build_and_test.sh --- a/build_and_test.sh +++ b/build_and_test.sh @@ -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 diff --git a/installDeps.sh b/installDeps.sh deleted file mode 100644 --- a/installDeps.sh +++ /dev/null @@ -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 diff --git a/prepare_release.sh b/prepare_release.sh --- a/prepare_release.sh +++ b/prepare_release.sh @@ -11,7 +11,8 @@ PATH="$(pwd)/.cabal-sandbox/bin:$PATH" -./installDeps.sh ./build_and_test.sh ./build_haddock.sh cabal check +cabal sdist + diff --git a/run.sh b/run.sh deleted file mode 100644 --- a/run.sh +++ /dev/null @@ -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 $@ 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 @@ -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) diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs --- a/src/lib/B9/B9Monad.hs +++ b/src/lib/B9/B9Monad.hs @@ -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 (..)) diff --git a/src/lib/B9/ConfigUtils.hs b/src/lib/B9/ConfigUtils.hs --- a/src/lib/B9/ConfigUtils.hs +++ b/src/lib/B9/ConfigUtils.hs @@ -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)) diff --git a/src/lib/B9/Content/ErlTerms.hs b/src/lib/B9/Content/ErlTerms.hs --- a/src/lib/B9/Content/ErlTerms.hs +++ b/src/lib/B9/Content/ErlTerms.hs @@ -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 diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs --- a/src/lib/B9/LibVirtLXC.hs +++ b/src/lib/B9/LibVirtLXC.hs @@ -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 =