b9 0.5.5 → 0.5.7

raw patch · 18 files changed

+97/−176 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• b9.cabal +1/−1
• src/lib/B9.hs +14/−16
• src/lib/B9/ArtifactGenerator.hs +8/−8
• src/lib/B9/ArtifactGeneratorImpl.hs +12/−19
• src/lib/B9/B9Config.hs +6/−6
• src/lib/B9/B9Monad.hs +1/−1
• src/lib/B9/Builder.hs +21/−86
• src/lib/B9/ConfigUtils.hs +2/−4
• src/lib/B9/Content/ErlTerms.hs +11/−13
• src/lib/B9/Content/YamlObject.hs +3/−3
• src/lib/B9/DiskImages.hs +1/−1
• src/lib/B9/LibVirtLXC.hs +4/−4
• src/lib/B9/Repository.hs +7/−7
• src/lib/B9/RepositoryIO.hs +1/−1
• src/lib/B9/ShellScript.hs +2/−2
• src/lib/B9/VmBuilder.hs +1/−1
• src/tests/B9/Content/ErlangPropListSpec.hs +1/−2
• src/tests/B9/Content/YamlObjectSpec.hs +1/−1

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.5+version:             0.5.7  synopsis:            A tool and library for building virtual machine images. 

@@ -11,22 +11,20 @@  -} -module B9-       ( module B9.Builder-       , module System.Exit-       , module System.FilePath-       , module Control.Applicative-       , module Control.Monad-       , module Control.Monad.IO.Class-       , module Data.Monoid-       , module Data.List-       , module Data.Maybe-       , module Text.Printf-       , module Text.Show.Pretty-       , module Data.Version-       , configure-       , b9_version-       ) where+module B9 (configure, b9_version, module X) where+import Control.Applicative as X+import Control.Monad as X+import Control.Monad.IO.Class as X+import Data.Monoid as X+import Data.List as X+import Data.Maybe as X+import Text.Show.Pretty as X (ppShow)+import System.Exit as X (exitWith, ExitCode(..))+import System.FilePath as X+        (takeDirectory, takeFileName, replaceExtension, (</>), (<.>))+import Text.Printf as X (printf)+import Data.Version as X+import B9.Builder as X  import Control.Applicative import Control.Monad

@@ -185,12 +185,12 @@   deriving (Read, Show, Typeable, Data, Eq)  instance Arbitrary ArtifactGenerator where-  arbitrary = oneof [ Sources <$> (halfSize arbitrary) <*> (halfSize arbitrary)-                    , Let <$> (halfSize arbitraryEnv) <*> (halfSize arbitrary)-                    , (halfSize arbitraryEachT) <*> (halfSize arbitrary)-                    , (halfSize arbitraryEach) <*> (halfSize arbitrary)-                    , Artifact <$> (smaller arbitrary)-                               <*> (smaller arbitrary)+  arbitrary = oneof [ Sources <$> halfSize arbitrary <*> halfSize arbitrary+                    , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary+                    , halfSize arbitraryEachT <*> halfSize arbitrary+                    , halfSize arbitraryEach <*> halfSize arbitrary+                    , Artifact <$> smaller arbitrary+                               <*> smaller arbitrary                     , pure EmptyArtifact                     ] @@ -204,8 +204,8 @@  arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator) arbitraryEach = sized $ \n ->-   Each <$> listOf ((,) <$> (listOf1-                               (choose ('a', 'z')))+   Each <$> listOf ((,) <$> listOf1+                               (choose ('a', 'z'))                         <*> vectorOf n (halfSize                                           (listOf1                                              (choose ('a', 'z')))))

@@ -99,9 +99,7 @@   in ce { agEnv = newEnv }  withXBindings :: [(String,[String])] -> CGParser () -> CGParser ()-withXBindings bs cp = do-  (flip local cp) `mapM_` (addBindings <$> (allXBindings bs))-+withXBindings bs cp = (`local` cp) `mapM_` (addBindings <$> allXBindings bs)   where     allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs                                               , c <- allXBindings rest]@@ -114,7 +112,7 @@ eachBindingSetT g vars valueSets =   if all ((== length vars) . length) valueSets     then return (zip vars <$> valueSets)-    else (cgError+    else cgError             (printf                "Error in 'Each' binding during artifact \                            \generation in:\n '%s'.\n\nThe variable list\n\@@ -123,7 +121,7 @@                (ppShow g)                (ppShow vars)                (length vars)-               (ppShow (head (dropWhile ((== length vars) . length) valueSets)))))+               (ppShow (head (dropWhile ((== length vars) . length) valueSets))))  eachBindingSet :: ArtifactGenerator                -> [(String, [String])]@@ -134,7 +132,7 @@    where     bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]-    checkInput = when (1 /= (length $ nub $ length . snd <$> kvs))+    checkInput = when (1 /= length (nub $ length . snd <$> kvs))                    (cgError                       (printf                          "Error in 'Each' binding: \n%s\n\@@ -176,19 +174,17 @@  execIGEnv :: InstanceGenerator CGEnv           -> Either String (InstanceGenerator [SourceGenerator])-execIGEnv (IG iid (CGEnv env sources) assembly) = do-  IG iid <$> sourceGens <*> pure (substAssembly env assembly)+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 p = everywhere gsubst p+substAssembly env = everywhere gsubst   where     gsubst :: Data a => a -> a-    gsubst = mkT substAssembly_-             `extT` (substImageTarget env)-             `extT` (substVmScript env)+    gsubst = mkT substAssembly_ `extT` substImageTarget env+             `extT` substVmScript env      substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)     substAssembly_ vm = vm@@ -263,7 +259,7 @@               SGFiles froms -> do                 sources <- mapM (sgReadSourceFile env) froms                 return (mconcat sources)-              SGContent c -> do+              SGContent c ->                 withEnvironment env (render c)   traceL (printf "rendered: \n%s\n" (T.unpack (E.decodeUtf8 result)))   liftIO (B.writeFile toAbs result)@@ -337,9 +333,7 @@       (IID iidStr) = iid   unless success (errorL err_msg >> error err_msg)   return [VmImagesTarget]-createTarget _ instanceDir (CloudInit types outPath) = do-  mapM create_ types-+createTarget _ instanceDir (CloudInit types outPath) = mapM create_ types   where     create_ CI_DIR = do       let ciDir = outPath@@ -383,14 +377,13 @@       let vfatFile = outPath <.> "vfat"           tmpFile = buildDir </> takeFileName vfatFile       ensureDir tmpFile-      files <- (map (instanceDir </>)) <$> getDirectoryFiles instanceDir+      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-        (intercalate " " ((printf "mcopy -oi '%s' " tmpFile)-                          : (printf "'%s'" <$> files))+        (unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))          ++ " ::")       dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)       ensureDir vfatFile

@@ -1,4 +1,3 @@-{-# Language DeriveDataTypeable #-} {-| Static B9 configuration. Read, write and merge configurable properties. The properties are independent of specific build targets.@@ -18,6 +17,7 @@                    ) where  import Data.Monoid+import Data.Maybe (fromMaybe) import Control.Monad import Control.Exception import Data.Function (on)@@ -106,12 +106,12 @@  getB9ConfigFile :: MonadIO m => Maybe SystemPath -> m FilePath getB9ConfigFile mCfgFile = do-  cfgFile <- resolve (maybe defaultB9ConfigFile id mCfgFile)+  cfgFile <- resolve (fromMaybe defaultB9ConfigFile mCfgFile)   ensureDir cfgFile   return cfgFile  writeB9Config :: MonadIO m-                 => (Maybe SystemPath)+                 => Maybe SystemPath                  -> ConfigParser                  -> m () writeB9Config cfgFileIn cp = do@@ -119,7 +119,7 @@   liftIO (writeFile cfgFile (to_string cp))  writeInitialB9Config :: MonadIO m-                        => (Maybe SystemPath)+                        => Maybe SystemPath                         -> B9Config                         -> ConfigParser                         -> m ()@@ -131,7 +131,7 @@   cfgFile <- resolve cfgPath   ensureDir cfgFile   exists <- liftIO $ doesFileExist cfgFile-  when (not exists) $+  unless exists $     let res = do           let cp = emptyCP               c = defaultB9Config <> cliCfg@@ -151,7 +151,7 @@      Left e -> liftIO (throwIO (IniFileException cfgFile e))      Right cp -> liftIO (writeFile cfgFile (to_string cp)) -readB9Config :: MonadIO m => (Maybe SystemPath) -> m ConfigParser+readB9Config :: MonadIO m => Maybe SystemPath -> m ConfigParser readB9Config Nothing = readB9Config (Just defaultB9ConfigFile) readB9Config (Just cfgFile) = readIniFile cfgFile 

@@ -68,7 +68,7 @@     withBuildDir buildId = bracket (createBuildDir buildId) removeBuildDir      run' buildId now buildDir logFileHandle = do-      maybe empty setCurrentDirectory (buildDirRoot cfg)+      maybe (print "Keeping PWD as CWD") setCurrentDirectory (buildDirRoot cfg)       -- Check repositories       repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (repositoryCache cfg))       let remoteRepos = getConfiguredRemoteRepos cfgParser

@@ -2,28 +2,27 @@ {-| Highest-level build functions and and B9-re-exports. -}-module B9.Builder ( module B9.B9Monad-                  , module B9.ConfigUtils-                  , module B9.B9Config-                  , module B9.ExecEnv-                  , module B9.DiskImages-                  , module B9.DiskImageBuilder-                  , module B9.ShellScript-                  , module B9.Repository-                  , module B9.RepositoryIO-                  , module B9.ArtifactGenerator-                  , module B9.ArtifactGeneratorImpl-                  , module B9.Vm-                  , module B9.VmBuilder-                  , module B9.Content.AST-                  , module B9.Content.StringTemplate-                  , module B9.Content.ErlTerms-                  , module B9.Content.ErlangPropList-                  , module B9.Content.YamlObject-                  , module B9.Content.Generator-                  , module B9.QCUtil-                  , buildArtifacts-                  ) where+module B9.Builder (buildArtifacts, module X) where+import B9.B9Monad as X+import B9.ConfigUtils as X+import B9.B9Config as X+import B9.ExecEnv as X+import B9.DiskImages as X+import B9.DiskImageBuilder as X+import B9.ShellScript as X+import B9.Repository as X+import B9.RepositoryIO as X+import B9.ArtifactGenerator as X+import B9.ArtifactGeneratorImpl as X+import B9.Vm as X+import B9.VmBuilder as X+import B9.QCUtil as X+import B9.Content.AST as X+import B9.Content.StringTemplate as X+import B9.Content.ErlTerms as X+import B9.Content.ErlangPropList as X+import B9.Content.YamlObject as X+import B9.Content.Generator as X  import Data.Monoid import Text.Printf ( printf )@@ -76,67 +75,3 @@     Right parsedCfg ->       let cfg = defaultB9Config <> parsedCfg <> cliCfg           in f cfg--{--xxx :: ArtifactGenerator-xxx =-  Each-   [("domain", ["tec.lbaum.eu"-               ,"test.meetyoo.de"])-   ,("altdomain", ["tec.lbaum.eu"-                  ,"testyoo.de"])-   ,("ip_prefix", ["10.1.40"-                  ,"192.168.111"])-   ,("ip_prefix_erl", ["10,1,40"-                      ,"192,168,111"])-   ,("chassis_config", ["COMMON/chassis/switchraumOG4-motorola"-                       ,"COMMON/chassis/meetyoo-test"])-   ,("sipstack_config", ["COMMON/sipstack/lbm-QSC"-                        ,"COMMON/sipstack/meetyoo-test"])-   ,("outbound_proxies_config", ["COMMON/outbound_proxies/lbm-QSC"-                                ,"COMMON/outbound_proxies/meetyoo-test"])-   ]-  [Let-   [("dns","ns1.${domain}")-   ,("dns_ip", "${ip_prefix}.10")-   ,("gw", "lb-gw1.${domain}")-   ,("gw_ip","${ip_prefix}.254")-   ,("syslog","lb-log1.${domain}")-   ,("syslog_ip", "${ip_prefix}.110")-   ,("mail", "mail.${altdomain}")-   ,("mail_ip", "${ip_prefix}.11")-   ,("file_server", "lb-ds1.${domain}")-   ,("file_server_ip", "${ip_prefix}.111")-   ,("tts", "lb-tts1.${domain}")-   ,("tts_ip", "${ip_prefix}.102")-   ,("mrfc", "lb-mrfc1.${domain}")-   ,("mrfc_ip", "${ip_prefix}.103")-   ,("sipproxy", "lb-sipproxy1.${domain}")-   ,("db", "lb-db1.${domain}")-   ,("db_ip", "${ip_prefix}.101")-   ,("app", "lb-app1.${domain}")-   ,("app_ip", "${ip_prefix}.100")-   ,("freeswitch", "lb-fs1.${domain}")-   ,("freeswitch_ip", "${ip_prefix}.113")-   ,("mp1", "lb-mp1.${domain}")-   ,("mp1_ip", "${ip_prefix}.112")-   ,("mrfp1", "lb-mrfp1.${domain}")-   ,("mrfp1_ip", "${ip_prefix}.106")-   ,("display1", "lb-dp1.${domain}")-   ,("display1_ip", "${ip_prefix}.105")-   ,("rtpproxy1", "lb-rp1.${domain}")-   ,("rtpproxy1_ip", "${ip_prefix}.120")]-   [Sources [YamlLiteral-               "user-data"-               (YamlDict-                 [("write_files"-                  ,YamlEmbedString-                     (ErlangTerms-                        "runtime.config"-                        [Template "${chassis_config}", Template "${sipstack_config}"]))])-            ]-            [Artifact (IID "$hostname")-                      (CloudInit [CI_DIR,CI_ISO] "${out_dir}/mrfp/cloud-init/${instance_id}")-            ]-   ]]--}

@@ -94,8 +94,7 @@ maybeConsult (Just f) defaultArg = liftIO $ do   exists <- doesFileExist f   if exists-    then do-      consult f+    then consult f     else return defaultArg  maybeConsultSystemPath :: (MonadIO m, Read a) => Maybe SystemPath -> a -> m a@@ -104,8 +103,7 @@   f' <- resolve f   exists <- doesFileExist f'   if exists-    then do-      consult f'+    then consult f'     else return defaultArg  data IniFileException = IniFileException FilePath CPError

@@ -246,32 +246,30 @@        <|>       do char 'x'-         (do ds <- between (char '{') (char '}') (fmap hexVal <$> many1 hexDigit)-             let val = foldl (\acc v -> acc * 16 + v) 0 ds-             return (toEnum val)+         do ds <- between (char '{') (char '}') (fmap hexVal <$> many1 hexDigit)+            let val = foldl (\acc v -> acc * 16 + v) 0 ds+            return (toEnum val)           <|>           do x1 <- hexVal <$> hexDigit              x2 <- hexVal <$> hexDigit;-             return (toEnum ((x1*16)+x2)))+             return (toEnum ((x1*16)+x2))        <|>       do o1 <- octVal <$> octDigit-         (do o2 <- octVal <$>  octDigit-             (do o3 <- octVal <$>  octDigit-                 return (toEnum ((((o1*8)+o2)*8)+o3))-              <|>-              return (toEnum ((o1*8)+o2)))-          <|>-          return (toEnum o1))+         do o2 <- octVal <$> octDigit+            do o3 <- octVal <$> octDigit+               return (toEnum ((((o1*8)+o2)*8)+o3))+              <|> return (toEnum ((o1*8)+o2))+          <|> return (toEnum o1)        <|>       choice (zipWith escapedChar codes replacements))   where     escapedChar code replacement = char code >> return replacement     codes =-      ['0'   , 'b'  , 'd'  , 'e'  , 'f' , 'n' , 'r' , 's' , 't' , 'v' ,'\\','\"','\'']+      "0bdefnrstv\\\"'"     replacements =-      ['\NUL', '\BS','\DEL','\ESC','\FF','\LF','\CR','\SP','\HT','\VT','\\','\"','\'']+      "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"     ccodes =       ['a' .. 'z'] ++ ['A' .. 'Z']     creplacements =

@@ -38,7 +38,7 @@  instance Show YamlObject where   show (YamlObject o) =-    "YamlObject " <> (show $ T.unpack $ E.decodeUtf8 $ encode o)+    "YamlObject " <> show (T.unpack $ E.decodeUtf8 $ encode o)  instance Semigroup YamlObject where @@ -59,7 +59,7 @@         array [t1,t2]  instance ConcatableSyntax YamlObject where-  decodeSyntax src str = do+  decodeSyntax src str =     case decodeEither str of       Left e ->         Left (printf "YamlObject parse error in file '%s':\n%s\n"@@ -87,7 +87,7 @@         return (foldl1 (<>) ys)       ASTEmbed c ->          YamlObject . toJSON . T.unpack . E.decodeUtf8 <$> render c-      ASTString str -> do+      ASTString str ->         return (YamlObject (toJSON str))       ASTParse src@(Source _ srcPath) -> do         c <- readTemplateFile src

@@ -137,7 +137,7 @@ -- | Shared images are orderd by name, build date and build id instance Ord SharedImage where   compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =-    (compare n n') <> (compare d d') <> (compare b b')+    compare n n' <> compare d d' <> compare b b'  newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show) newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show)

@@ -47,7 +47,7 @@     successMarkerCmd scriptDirGuest =       In scriptDirGuest [Run "touch" [successMarkerFile]] -    execute (Context scriptDirHost uuid domainFile cfg) = do+    execute (Context scriptDirHost _uuid domainFile cfg) = do       let virsh = virshCommand cfg       cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile       -- cmd $ printf "%s console %U" virsh uuid@@ -184,7 +184,7 @@     let geto :: (Get_C a, Read a)              => OptionSpec -> a -> a         geto = getOptionOr cp cfgFileSection-    return $+    return       LibVirtLXCConfig { useSudo = geto useSudoK $                          useSudo defaultLibVirtLXCConfig                        , virshPath = geto virshPathK $@@ -237,8 +237,8 @@   \  <devices>\n\   \    <emulator>" ++ emulator cfg ++ "</emulator>\n"   ++ unlines (libVirtNetwork (networkId cfg) ++-              (fsImage <$> (envImageMounts e)) ++-              (fsSharedDir <$> (envSharedDirectories e))) ++ "\n" +++              (fsImage <$> envImageMounts e) +++              (fsSharedDir <$> envSharedDirectories e)) ++ "\n" ++   "    <filesystem type='mount'>\n\   \      <source dir='" ++ scriptDirHost ++ "'/>\n\   \      <target dir='" ++ scriptDirGuest ++ "'/>\n\

@@ -63,10 +63,10 @@ remoteRepoCheckSshPrivKey (RemoteRepo rId rp (SshPrivKey keyFile) h u) = do   exists <- liftIO (doesFileExist keyFile)   keyFile' <- liftIO (canonicalizePath keyFile)-  when (not exists)-       (error (printf "SSH Key file '%s' for repository '%s' is missing."-                      keyFile'-                      rId))+  unless exists+         (error (printf "SSH Key file '%s' for repository '%s' is missing."+                        keyFile'+                        rId))   return (RemoteRepo rId rp (SshPrivKey keyFile') h u)  -- | Initialize the repository; load the corresponding settings from the config@@ -135,12 +135,12 @@       where         getsec :: Get_C a =>  OptionSpec -> Either CPError a         getsec = get cp section-        parseResult = do+        parseResult =           RemoteRepo repoId             <$> getsec repoRemotePathK             <*> (SshPrivKey <$> getsec repoRemoteSshKeyK)-            <*> (SshRemoteHost <$> ((,) <$> (getsec repoRemoteSshHostK)-                                        <*> (getsec repoRemoteSshPortK)))+            <*> (SshRemoteHost <$> ((,) <$> getsec repoRemoteSshHostK+                                        <*> getsec repoRemoteSshPortK))             <*> (SshRemoteUser <$> getsec repoRemoteSshUserK)           where             repoId = let prefixLen = length section - suffixLen

@@ -50,7 +50,7 @@           traceL (printf "reading contents of directory '%s'" dir)           ensureDir (dir ++ "/")           files <- liftIO (getDirectoryContents dir)-          return ((dir </>) <$> (filter (matchGlob glob) files))+          return ((dir </>) <$> filter (matchGlob glob) files)  -- | Push a file from the cache to a remote repository pushToRepo :: RemoteRepo -> FilePath -> FilePath -> B9 ()

@@ -72,9 +72,9 @@   where     toLLC :: Script -> Reader Ctx [Cmd]     toLLC NoOP = return []-    toLLC (In d cs) = local (\ ctx -> ctx { ctxCwd = (Cwd d) })+    toLLC (In d cs) = local (\ ctx -> ctx{ctxCwd = Cwd d})                       (toLLC (Begin cs))-    toLLC (As u cs) = local (\ ctx -> ctx { ctxUser = (User u) })+    toLLC (As u cs) = local (\ ctx -> ctx{ctxUser = User u})                       (toLLC (Begin cs))     toLLC (IgnoreErrors b cs) = local (\ ctx -> ctx { ctxIgnoreErrors = b })                                 (toLLC (Begin cs))

@@ -92,7 +92,7 @@                       (Resources AutomaticRamSize 8 cpu))  createSharedDirs :: FilePath -> [SharedDirectory] -> B9 [SharedDirectory]-createSharedDirs instanceDir sharedDirsIn = mapM createSharedDir sharedDirsIn+createSharedDirs instanceDir = mapM createSharedDir   where     createSharedDir (SharedDirectoryRO d m) = do       d' <- createAndCanonicalize d

@@ -13,8 +13,7 @@ import B9.Content.AST  spec :: Spec-spec = do-+spec =   describe "ErlangPropList" $ do      it "implements ConcatableSyntax method decodeSyntax" $

@@ -10,7 +10,7 @@ import B9.Content.AST  spec :: Spec-spec = do+spec =   describe "YamlObject" $ do      it "combines primitives by putting them in an array" $