b9 0.5.44 → 0.5.46

raw patch · 18 files changed

+571/−480 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• b9.cabal +2/−1
• src/cli/Main.hs +10/−18
• src/lib/B9.hs +26/−28
• src/lib/B9/ArtifactGenerator.hs +20/−19
• src/lib/B9/ArtifactGeneratorImpl.hs +13/−18
• src/lib/B9/B9Config.hs +87/−81
• src/lib/B9/B9Config/LibVirtLXC.hs +15/−15
• src/lib/B9/B9Config/Repository.hs +38/−37
• src/lib/B9/B9Monad.hs +54/−76
• src/lib/B9/Content/StringTemplate.hs +1/−3
• src/lib/B9/DiskImageBuilder.hs +111/−42
• src/lib/B9/DiskImages.hs +10/−10
• src/lib/B9/LibVirtLXC.hs +1/−5
• src/lib/B9/Repository.hs +1/−1
• src/lib/B9/RepositoryIO.hs +1/−3
• src/lib/B9/VmBuilder.hs +1/−1
• src/lib/Data/ConfigFile/B9Extras.hs +62/−122
• src/lib/System/IO/B9Extras.hs +118/−0

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.44+version:             0.5.46  synopsis:            A tool and library for building virtual machine images. @@ -98,6 +98,7 @@                    , B9.Vm                    , B9.VmBuilder                    , Data.ConfigFile.B9Extras+                   , System.IO.B9Extras   other-modules:   Paths_b9   -- other-extensions:   build-depends:     ConfigFile >= 1.1.4

@@ -7,7 +7,7 @@  main :: IO () main = do-    b9Opts  <- parseCommandLine+    b9Opts <- parseCommandLine     applyB9RunParameters b9Opts  @@ -40,7 +40,7 @@         (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))         (  fullDesc         <> progDesc-               "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files  trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'"+               "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files  trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${buildDirRoot} if not otherwise specified in the config file, or via the '-b' option."         <> headerDoc (Just b9HelpHeader)         )     )@@ -78,14 +78,8 @@                 )         <*> optional                 ( strOption-                    (  help "Output file for a command/timing profile"-                    <> long "profile-file"-                    <> metavar "FILENAME"-                    )-                )-        <*> optional-                ( strOption-                    (  help "Root directory for build directories"+                    (  help+                          "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${buildDirRoot}."                     <> short 'b'                     <> long "build-root-dir"                     <> metavar "DIRECTORY"@@ -122,13 +116,12 @@         -> Bool         -> Maybe FilePath         -> Maybe FilePath-        -> Maybe FilePath         -> Bool         -> Bool         -> Maybe FilePath         -> Maybe String         -> B9ConfigOverride-    toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique mRepoCache repo+    toGlobalOpts cfg verbose quiet logF buildRoot keep notUnique mRepoCache repo         = let minLogLevel = if verbose                   then Just LogTrace                   else if quiet then Just LogError else Nothing@@ -138,8 +131,6 @@                       .~ minLogLevel                       &  logFile                       .~ logF-                      &  profileFile-                      .~ profF                       &  buildDirRoot                       .~ buildRoot                       &  keepTempDirs@@ -214,7 +205,9 @@            )     <> command            "list"-           (info (pure (void runListSharedImages)) (progDesc "List shared images."))+           ( info (pure (void runListSharedImages))+                  (progDesc "List shared images.")+           )     <> command            "add-repo"            ( info (runAddRepo <$> remoteRepoParser)@@ -222,9 +215,8 @@            )     <> command            "reformat"-           ( info-               ( runFormatBuildFiles    <$> buildFileParser              )-               (progDesc "Re-Format all build files.")+           ( info (runFormatBuildFiles <$> buildFileParser)+                  (progDesc "Re-Format all build files.")            )     ) 

@@ -43,7 +43,7 @@ import Text.Printf as X (printf) import Data.Version as X import B9.B9Monad as X-import Data.ConfigFile.B9Extras as X+import System.IO.B9Extras as X import B9.B9Config as X import B9.ExecEnv as X import B9.DiskImages as X@@ -101,26 +101,24 @@ runPush name = localRuntimeConfig (keepTempDirs .~ False) $ run $ do   conf <- getConfig   if isNothing (conf ^. repository)-    then-      errorExitL-        "No repository specified! Use '-r' to specify a repo BEFORE 'push'."-    else-      pushSharedImageLatestVersion name+    then errorExitL+      "No repository specified! Use '-r' to specify a repo BEFORE 'push'."+    else pushSharedImageLatestVersion name  -- | Either pull a list of available 'SharedImageName's from the remote -- repository if 'Nothing' is passed as parameter, or pull the latest version -- of the image from the remote repository. Note: The remote repository is -- specified in the 'B9Config'. runPull :: MonadIO m => Maybe SharedImageName -> B9ConfigAction m ()-runPull mName =-  localRuntimeConfig (keepTempDirs .~ False)-                     (run (pullRemoteRepos >> maybePullImage))-  where maybePullImage =-          mapM_ (\name -> pullLatestImage name >>= failIfFalse name) mName-        failIfFalse _name True =-          return ()-        failIfFalse name False =-          errorExitL (printf "failed to pull: %s" (show name))+runPull mName = localRuntimeConfig (keepTempDirs .~ False)+                                   (run (pullRemoteRepos >> maybePullImage))+ where+  maybePullImage = mapM_+    ( \name ->+      pullLatestImage name >>= maybe (failPull name) (const (return ()))+    )+    mName+  failPull name = errorExitL (printf "failed to pull: %s" (show name))  -- | Execute an interactive root shell in a running container from a -- 'SharedImageName'.@@ -159,15 +157,16 @@         putStrLn "DELETING FILES:"         putStrLn (unlines filesToDelete)         mapM_ removeIfExists filesToDelete-  obsoleteSharedmages :: [SharedImage] -> [SharedImage]-  obsoleteSharedmages =-    concatMap (tail . reverse) . filter ((> 1) . length) . groupBy-      ((==) `on` siName)-  removeIfExists :: FilePath -> IO ()-  removeIfExists fileName = removeFile fileName `catch` handleExists    where-    handleExists e | isDoesNotExistError e = return ()-                   | otherwise             = throwIO e+    obsoleteSharedmages :: [SharedImage] -> [SharedImage]+    obsoleteSharedmages =+      concatMap (tail . reverse) . filter ((> 1) . length) . groupBy+        ((==) `on` sharedImageName)+    removeIfExists :: FilePath -> IO ()+    removeIfExists fileName = removeFile fileName `catch` handleExists+     where+      handleExists e | isDoesNotExistError e = return ()+                     | otherwise             = throwIO e  -- | Clear the shared image cache for a remote. Note: The remote repository is -- specified in the 'B9Config'.@@ -195,11 +194,10 @@       allRepos <- getRemoteRepos       if isNothing remoteRepo         then liftIO $ do-          putStrLn "Showing local shared images only."-          putStrLn-            "\nTo view the contents of a remote repo add \n\-                        \the '-r' switch with one of the remote \n\-                        \repository ids."+          putStrLn "Showing local shared images only.\n"+          putStrLn "To view the contents of a remote repo add"+          putStrLn "the '-r' switch with one of the remote"+          putStrLn "repository ids."         else liftIO $ putStrLn           (  "Showing shared images on: "           ++ remoteRepoRepoId (fromJust remoteRepo)

@@ -179,7 +179,7 @@ getArtifactSourceFiles (FromContent   f _) = [f] getArtifactSourceFiles (FromFile      f _) = [f] getArtifactSourceFiles (IntoDirectory pd as) =-    (pd</>) <$> (as >>= getArtifactSourceFiles)+    (pd </>) <$> (as >>= getArtifactSourceFiles) getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles getArtifactSourceFiles (SetPermissions _ _ _ as) =     as >>= getArtifactSourceFiles@@ -275,11 +275,11 @@ 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+  where+    getCloudInitOutputFiles baseName t = case t of+        CI_ISO  -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]+        CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]+        CI_DIR  -> AssemblyCopiesSourcesToDirectory baseName   -- * QuickCheck instances@@ -297,21 +297,21 @@  arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator) arbitraryEachT =-    sized $-    \n ->-         EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*>-         oneof-             [ listOf (vectorOf n (halfSize arbitrary))-             , listOf1 (listOf (halfSize arbitrary))]+    sized+        $ \n ->+              EachT+                  <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z'))))+                  <*> oneof+                          [ listOf (vectorOf n (halfSize arbitrary))+                          , listOf1 (listOf (halfSize arbitrary))+                          ]  arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator)-arbitraryEach =-    sized $-    \n ->-         Each <$>-         listOf-             ((,) <$> listOf1 (choose ('a', 'z')) <*>-              vectorOf n (halfSize (listOf1 (choose ('a', 'z')))))+arbitraryEach = sized $ \n -> Each <$> listOf+    ( (,) <$> listOf1 (choose ('a', 'z')) <*> vectorOf+        n+        (halfSize (listOf1 (choose ('a', 'z'))))+    )   instance Arbitrary ArtifactSource where@@ -336,3 +336,4 @@  instance Arbitrary CloudInitType where     arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR]+

@@ -9,7 +9,7 @@ import B9.VmBuilder import B9.Vm import B9.DiskImageBuilder-import Data.ConfigFile.B9Extras hiding (tell)+import System.IO.B9Extras (ensureDir, getDirectoryFiles) import B9.Content.StringTemplate import B9.Content.Generator import B9.Content.AST@@ -47,15 +47,13 @@ getArtifactOutputFiles :: ArtifactGenerator -> Either String [FilePath] getArtifactOutputFiles g =   concatMap getOutputs <$> evalArtifactGenerator undefined undefined [] g-  where-    getOutputs  (IG _ sgs a) =-      let-          toOutFile (AssemblyGeneratesOutputFiles fs) = fs-          toOutFile (AssemblyCopiesSourcesToDirectory pd) =-            let sourceFiles = sourceGeneratorOutputFile <$> sgs-            in (pd </>) <$> sourceFiles--      in getAssemblyOutput  a >>= toOutFile+ where+  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]@@ -124,7 +122,7 @@   in  ce { agEnv = newEnv }  withXBindings :: [(String, [String])] -> CGParser () -> CGParser ()-withXBindings bs cp = (`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 ]@@ -135,7 +133,7 @@   -> [String]   -> [[String]]   -> CGParser [[(String, String)]]-eachBindingSetT g vars valueSets = if all ((==length vars) . length) valueSets+eachBindingSetT g vars valueSets = if all ((== length vars) . length) valueSets   then return (zip vars <$> valueSets)   else cgError     ( printf@@ -143,7 +141,7 @@       (ppShow g)       (ppShow vars)       (length vars)-      (ppShow (head (dropWhile ((==length vars) . length) valueSets)))+      (ppShow (head (dropWhile ((== length vars) . length) valueSets)))     )  eachBindingSet@@ -363,7 +361,7 @@           ensureDir t           copyFile f t         )-        (((instanceDir</>) &&& (ciDir</>)) <$> files)+        (((instanceDir </>) &&& (ciDir </>)) <$> files)       )     infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))     return (CloudInitTarget CI_DIR ciDir)@@ -395,7 +393,7 @@     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)@@ -409,6 +407,3 @@     liftIO (copyFile tmpFile vfatFile)     infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))     return (CloudInitTarget CI_ISO vfatFile)---

@@ -8,7 +8,6 @@                    , buildDirRoot                    , keepTempDirs                    , execEnvType-                   , profileFile                    , envVars                    , uniqueBuildDirs                    , repositoryCache@@ -16,6 +15,7 @@                    , interactive                    , libVirtLXCConfigs                    , remoteRepos+                   , maxLocalSharedImageRevisions                    , B9ConfigOverride(..)                    , noB9ConfigOverride                    , B9ConfigAction()@@ -35,12 +35,12 @@                    , defaultRepositoryCache                    , defaultB9Config                    , openOrCreateB9Config-                   , writeB9ConfigParser+                   , writeB9CPDocument                    , readB9Config                    , parseB9Config                    , appendPositionalArguments-                   , modifyConfigParser-                   , b9ConfigToConfigParser+                   , modifyCPDocument+                   , b9ConfigToCPDocument                    , LogLevel(..)                    , ExecEnvType (..)                    , BuildVariables@@ -56,13 +56,14 @@ import Control.Monad.Reader import Control.Monad.Writer import System.Directory+import System.IO.B9Extras (SystemPath(..), resolve, ensureDir) import qualified Data.Semigroup as Sem import Data.List (partition, sortBy) import Data.ConfigFile.B9Extras-          ( SystemPath(..), ConfigParser, CPError, Get_C-          , OptionSpec, resolve, ensureDir, readIniFile-          , IniFileException(..), merge, to_string-          , add_section, emptyCP, setshow, get)+          ( CPDocument, CPError, CPGet+          , CPOptionSpec, readCPDocument+          , CPReadException(..), mergeCP, toStringCP+          , addSectionCP, emptyCP, setShowCP, readCP ) import B9.B9Config.LibVirtLXC as X import B9.B9Config.Repository as X import Text.Printf (printf)@@ -79,12 +80,12 @@                          , _buildDirRoot :: Maybe FilePath                          , _keepTempDirs :: Bool                          , _execEnvType :: ExecEnvType-                         , _profileFile :: Maybe FilePath                          , _envVars :: BuildVariables                          , _uniqueBuildDirs :: Bool                          , _repositoryCache :: Maybe SystemPath                          , _repository :: Maybe String                          , _interactive :: Bool+                         , _maxLocalSharedImageRevisions :: Maybe Int                          , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig                          , _remoteRepos :: [RemoteRepo]                          } deriving (Show)@@ -96,20 +97,20 @@       , _buildDirRoot = getLast $ on mappend (Last . _buildDirRoot) c c'       , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'       , _execEnvType = LibVirtLXC-      , _profileFile = getLast $ on mappend (Last . _profileFile) c c'       , _envVars = on mappend _envVars c c'       , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')       , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'       , _repository = getLast ((mappend `on` (Last . _repository)) c c')       , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')+      , _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')       , _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c')       , _remoteRepos = (mappend `on` _remoteRepos) c c'       }  instance Monoid B9Config where   mappend = (Sem.<>)-  mempty = B9Config Nothing Nothing Nothing False LibVirtLXC Nothing [] True-                    Nothing Nothing False Nothing []+  mempty = B9Config Nothing Nothing Nothing False LibVirtLXC [] True+                    Nothing Nothing False Nothing Nothing []  -- | Override b9 configuration items and/or the path of the b9 configuration file. -- This is useful, i.e. when dealing with command line parameters.@@ -204,7 +205,7 @@       (res, permanentB9ConfigUpdates) <- runWriterT         (runReaderT (runB9ConfigAction act) runtimeCfg) -      let cpExtErr = modifyConfigParser cp <$> permanentB9ConfigUpdate+      let cpExtErr = modifyCPDocument cp <$> permanentB9ConfigUpdate           permanentB9ConfigUpdate = if null permanentB9ConfigUpdates             then Nothing             else Just (mconcat permanentB9ConfigUpdates)@@ -219,7 +220,7 @@           (return . Just)         )         cpExtErr-      mapM_ (writeB9ConfigParser (cfg ^. customB9ConfigPath)) cpExt+      mapM_ (writeB9CPDocument (cfg ^. customB9ConfigPath)) cpExt       return res -- | Run a 'B9ConfigAction' using 'noB9ConfigOverride'. -- See 'execB9ConfigAction' for more details.@@ -229,45 +230,45 @@ -- | Open the configuration file that contains the 'B9Config'. -- If the configuration does not exist, write a default configuration file, -- and create a all missing directories.-openOrCreateB9Config :: MonadIO m => Maybe SystemPath -> m ConfigParser+openOrCreateB9Config :: MonadIO m => Maybe SystemPath -> m CPDocument openOrCreateB9Config cfgPath = do   cfgFile <- resolve (fromMaybe defaultB9ConfigFile cfgPath)   ensureDir cfgFile   liftIO $ do     exists <- doesFileExist cfgFile     if exists-      then readIniFile (Path cfgFile)+      then readCPDocument (Path cfgFile)       else-        let res = b9ConfigToConfigParser defaultB9Config+        let res = b9ConfigToCPDocument defaultB9Config         in  case res of-              Left  e  -> throwIO (IniFileException cfgFile e)-              Right cp -> writeFile cfgFile (to_string cp) >> return cp+              Left  e  -> throwIO (CPReadException cfgFile e)+              Right cp -> writeFile cfgFile (toStringCP cp) >> return cp --- | Write the configuration in the 'ConfigParser' to either the user supplied+-- | Write the configuration in the 'CPDocument' to either the user supplied -- configuration file path or to 'defaultB9ConfigFile'. -- Create all missing (parent) directories.-writeB9ConfigParser :: MonadIO m => Maybe SystemPath -> ConfigParser -> m ()-writeB9ConfigParser cfgFileIn cp = do+writeB9CPDocument :: MonadIO m => Maybe SystemPath -> CPDocument -> m ()+writeB9CPDocument cfgFileIn cp = do   cfgFile <- resolve (fromMaybe defaultB9ConfigFile cfgFileIn)   ensureDir cfgFile-  liftIO (writeFile cfgFile (to_string cp))+  liftIO (writeFile cfgFile (toStringCP cp))   defaultB9Config :: B9Config defaultB9Config = B9Config-  { _verbosity         = Just LogInfo-  , _logFile           = Nothing-  , _buildDirRoot      = Nothing-  , _keepTempDirs      = False-  , _execEnvType       = LibVirtLXC-  , _profileFile       = Nothing-  , _envVars           = []-  , _uniqueBuildDirs   = True-  , _repository        = Nothing-  , _repositoryCache   = Just defaultRepositoryCache-  , _interactive       = False-  , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig-  , _remoteRepos       = []+  { _verbosity                    = Just LogInfo+  , _logFile                      = Nothing+  , _buildDirRoot                 = Nothing+  , _keepTempDirs                 = False+  , _execEnvType                  = LibVirtLXC+  , _envVars                      = []+  , _uniqueBuildDirs              = True+  , _repository                   = Nothing+  , _repositoryCache              = Just defaultRepositoryCache+  , _interactive                  = False+  , _maxLocalSharedImageRevisions = Just 2+  , _libVirtLXCConfigs            = Just defaultLibVirtLXCConfig+  , _remoteRepos                  = []   }  defaultRepositoryCache :: SystemPath@@ -284,73 +285,78 @@ keepTempDirsK = "keep_temp_dirs" execEnvTypeK :: String execEnvTypeK = "exec_env"-profileFileK :: String-profileFileK = "profile_file" envVarsK :: String envVarsK = "environment_vars" uniqueBuildDirsK :: String uniqueBuildDirsK = "unique_build_dirs" repositoryCacheK :: String repositoryCacheK = "repository_cache"+maxLocalSharedImageRevisionsK :: String+maxLocalSharedImageRevisionsK = "max_cached_shared_images" repositoryK :: String repositoryK = "repository" cfgFileSection :: String cfgFileSection = "global" --- | Parse a 'B9Config', modify it, and merge it back to the given 'ConfigParser'.-modifyConfigParser-  :: ConfigParser -> Endo B9Config -> Either CPError ConfigParser-modifyConfigParser cp f = do+-- | Parse a 'B9Config', modify it, and merge it back to the given 'CPDocument'.+modifyCPDocument :: CPDocument -> Endo B9Config -> Either CPError CPDocument+modifyCPDocument cp f = do   cfg <- parseB9Config cp-  cp2 <- b9ConfigToConfigParser (appEndo f cfg)-  return (merge cp cp2)+  cp2 <- b9ConfigToCPDocument (appEndo f cfg)+  return (mergeCP cp cp2) --- | Append a config file section for the 'B9Config' to an empty 'ConfigParser'.-b9ConfigToConfigParser :: B9Config -> Either CPError ConfigParser-b9ConfigToConfigParser c = do-  cp1 <- add_section emptyCP cfgFileSection-  cp2 <- setshow cp1 cfgFileSection verbosityK (_verbosity c)-  cp3 <- setshow cp2 cfgFileSection logFileK (_logFile c)-  cp4 <- setshow cp3 cfgFileSection buildDirRootK (_buildDirRoot c)-  cp5 <- setshow cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)-  cp6 <- setshow cp5 cfgFileSection execEnvTypeK (_execEnvType c)-  cp7 <- setshow cp6 cfgFileSection profileFileK (_profileFile c)-  cp8 <- setshow cp7 cfgFileSection envVarsK (_envVars c)-  cp9 <- setshow cp8 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)-  cpA <- setshow cp9 cfgFileSection repositoryCacheK (_repositoryCache c)+-- | Append a config file section for the 'B9Config' to an empty 'CPDocument'.+b9ConfigToCPDocument :: B9Config -> Either CPError CPDocument+b9ConfigToCPDocument c = do+  cp1 <- addSectionCP emptyCP cfgFileSection+  cp2 <- setShowCP cp1 cfgFileSection verbosityK (_verbosity c)+  cp3 <- setShowCP cp2 cfgFileSection logFileK (_logFile c)+  cp4 <- setShowCP cp3 cfgFileSection buildDirRootK (_buildDirRoot c)+  cp5 <- setShowCP cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)+  cp6 <- setShowCP cp5 cfgFileSection execEnvTypeK (_execEnvType c)+  cp7 <- setShowCP cp6 cfgFileSection envVarsK (_envVars c)+  cp8 <- setShowCP cp7 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)+  cp9 <- setShowCP cp8+                   cfgFileSection+                   maxLocalSharedImageRevisionsK+                   (_maxLocalSharedImageRevisions c)+  cpA <- setShowCP cp9 cfgFileSection repositoryCacheK (_repositoryCache c)   cpB <-     ( foldr (>=>)             return-            (libVirtLXCConfigToConfigParser <$> (_libVirtLXCConfigs c))+            (libVirtLXCConfigToCPDocument <$> (_libVirtLXCConfigs c))       )       cpA-  cpFinal <- (foldr (>=>) return (remoteRepoToConfigParser <$> _remoteRepos c))+  cpFinal <- (foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c))     cpB-  setshow cpFinal cfgFileSection repositoryK (_repository c)+  setShowCP cpFinal cfgFileSection repositoryK (_repository c) -readB9Config :: MonadIO m => Maybe SystemPath -> m ConfigParser-readB9Config cfgFile = readIniFile (fromMaybe defaultB9ConfigFile cfgFile)+readB9Config :: MonadIO m => Maybe SystemPath -> m CPDocument+readB9Config cfgFile = readCPDocument (fromMaybe defaultB9ConfigFile cfgFile) -parseB9Config :: ConfigParser -> Either CPError B9Config+parseB9Config :: CPDocument -> Either CPError B9Config parseB9Config cp =-  let getr :: (Get_C a) => OptionSpec -> Either CPError a-      getr = get cp cfgFileSection-      getB9Config =-        B9Config-          <$> getr verbosityK-          <*> getr logFileK-          <*> getr buildDirRootK-          <*> getr keepTempDirsK-          <*> getr execEnvTypeK-          <*> getr profileFileK-          <*> getr envVarsK-          <*> getr uniqueBuildDirsK-          <*> getr repositoryCacheK-          <*> getr repositoryK-          <*> pure False-          <*> Right (either (const Nothing) Just (parseLibVirtLXCConfig cp))-          <*> parseRemoteRepos cp-  in  getB9Config+  let+    getr :: (CPGet a) => CPOptionSpec -> Either CPError a+    getr = readCP cp cfgFileSection+    getB9Config =+      B9Config+        <$> getr verbosityK+        <*> getr logFileK+        <*> getr buildDirRootK+        <*> getr keepTempDirsK+        <*> getr execEnvTypeK+        <*> getr envVarsK+        <*> getr uniqueBuildDirsK+        <*> getr repositoryCacheK+        <*> getr repositoryK+        <*> pure False+        <*> pure+              (either (const Nothing) id (getr maxLocalSharedImageRevisionsK))+        <*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp))+        <*> parseRemoteRepos cp+  in+    getB9Config   -- | If environment variables @arg_1 .. arg_n@ are bound

@@ -1,5 +1,5 @@ module B9.B9Config.LibVirtLXC (-                        libVirtLXCConfigToConfigParser+                        libVirtLXCConfigToCPDocument                         , defaultLibVirtLXCConfig                         , parseLibVirtLXCConfig                      , LibVirtLXCConfig(..)@@ -98,22 +98,22 @@ guestRamSizeK :: String guestRamSizeK = "guest_ram_size" -libVirtLXCConfigToConfigParser-    :: LibVirtLXCConfig -> ConfigParser -> Either CPError ConfigParser-libVirtLXCConfigToConfigParser c cp = do-    cp1 <- add_section cp cfgFileSection-    cp2 <- setshow cp1 cfgFileSection useSudoK $ useSudo c-    cp3 <- set cp2 cfgFileSection virshPathK $ virshPath c-    cp4 <- set cp3 cfgFileSection emulatorK $ emulator c-    cp5 <- set cp4 cfgFileSection virshURIK $ virshURI c-    cp6 <- setshow cp5 cfgFileSection networkIdK $ networkId c-    cp7 <- setshow cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c-    setshow cp7 cfgFileSection guestRamSizeK $ guestRamSize c+libVirtLXCConfigToCPDocument+    :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument+libVirtLXCConfigToCPDocument c cp = do+    cp1 <- addSectionCP cp cfgFileSection+    cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c+    cp3 <- setCP cp2 cfgFileSection virshPathK $ virshPath c+    cp4 <- setCP cp3 cfgFileSection emulatorK $ emulator c+    cp5 <- setCP cp4 cfgFileSection virshURIK $ virshURI c+    cp6 <- setShowCP cp5 cfgFileSection networkIdK $ networkId c+    cp7 <- setShowCP cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c+    setShowCP cp7 cfgFileSection guestRamSizeK $ guestRamSize c -parseLibVirtLXCConfig :: ConfigParser -> Either CPError LibVirtLXCConfig+parseLibVirtLXCConfig :: CPDocument -> Either CPError LibVirtLXCConfig parseLibVirtLXCConfig cp =-    let getr :: (Get_C a) => OptionSpec -> Either CPError a-        getr = get cp cfgFileSection+    let getr :: (CPGet a) => CPOptionSpec -> Either CPError a+        getr = readCP cp cfgFileSection     in  LibVirtLXCConfig         <$> (getr useSudoK)         <*> (getr virshPathK)

@@ -4,13 +4,13 @@                               , SshPrivKey(..)                               , SshRemoteHost(..)                               , SshRemoteUser(..)-                              , remoteRepoToConfigParser+                              , remoteRepoToCPDocument                               , parseRemoteRepos                               ) where  import Data.Data import Data.List (isSuffixOf)-import Data.ConfigFile+import Data.ConfigFile.B9Extras  newtype RepoCache = RepoCache FilePath   deriving (Read, Show, Typeable, Data)@@ -36,45 +36,46 @@   -- | Persist a repo to a configuration file.-remoteRepoToConfigParser :: RemoteRepo-                      -> ConfigParser-                      -> Either CPError ConfigParser-remoteRepoToConfigParser repo cpIn = cpWithRepo-  where section = repoId ++ repoSectionSuffix-        (RemoteRepo repoId-                    remoteRootDir-                    (SshPrivKey keyFile)-                    (SshRemoteHost (host,port))-                    (SshRemoteUser user)) = repo-        cpWithRepo = do cp1 <- add_section cpIn section-                        cp2 <- set cp1 section repoRemotePathK remoteRootDir-                        cp3 <- set cp2 section repoRemoteSshKeyK keyFile-                        cp4 <- set cp3 section repoRemoteSshHostK host-                        cp5 <- setshow cp4 section repoRemoteSshPortK port-                        set cp5 section repoRemoteSshUserK user+remoteRepoToCPDocument :: RemoteRepo -> CPDocument -> Either CPError CPDocument+remoteRepoToCPDocument repo cpIn = cpWithRepo+ where+  section = repoId ++ repoSectionSuffix+  (RemoteRepo repoId remoteRootDir (SshPrivKey keyFile) (SshRemoteHost (host, port)) (SshRemoteUser user))+    = repo+  cpWithRepo = do+    cp1 <- addSectionCP cpIn section+    cp2 <- setCP cp1 section repoRemotePathK remoteRootDir+    cp3 <- setCP cp2 section repoRemoteSshKeyK keyFile+    cp4 <- setCP cp3 section repoRemoteSshHostK host+    cp5 <- setShowCP cp4 section repoRemoteSshPortK port+    setCP cp5 section repoRemoteSshUserK user  -- | Load a repository from a configuration file that has been written by -- 'writeRepositoryToB9Config'.-parseRemoteRepos :: ConfigParser -> Either CPError [RemoteRepo]+parseRemoteRepos :: CPDocument -> Either CPError [RemoteRepo] parseRemoteRepos cp = traverse parseRepoSection repoSections-  where-    repoSections =-          filter (repoSectionSuffix `isSuffixOf`) (sections cp)-    parseRepoSection section = parseResult-      where-        getsec :: Get_C a =>  OptionSpec -> Either CPError a-        getsec = get cp section-        parseResult =-          RemoteRepo repoId-            <$> getsec repoRemotePathK-            <*> (SshPrivKey <$> getsec repoRemoteSshKeyK)-            <*> (SshRemoteHost <$> ((,) <$> getsec repoRemoteSshHostK-                                        <*> getsec repoRemoteSshPortK))-            <*> (SshRemoteUser <$> getsec repoRemoteSshUserK)-          where-            repoId = let prefixLen = length section - suffixLen-                         suffixLen = length repoSectionSuffix-                         in take prefixLen section+ where+  repoSections = filter (repoSectionSuffix `isSuffixOf`) (sectionsCP cp)+  parseRepoSection section = parseResult+   where+    getsec :: CPGet a => CPOptionSpec -> Either CPError a+    getsec = readCP cp section+    parseResult =+      RemoteRepo repoId+        <$> getsec repoRemotePathK+        <*> (SshPrivKey <$> getsec repoRemoteSshKeyK)+        <*> (   SshRemoteHost+            <$> (   (,)+                <$> getsec repoRemoteSshHostK+                <*> getsec repoRemoteSshPortK+                )+            )+        <*> (SshRemoteUser <$> getsec repoRemoteSshUserK)+     where+      repoId =+        let prefixLen = length section - suffixLen+            suffixLen = length repoSectionSuffix+        in  take prefixLen section  repoSectionSuffix :: String repoSectionSuffix = "-repo"

@@ -19,7 +19,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.State-import Control.Lens((&), (.~))+import Control.Lens((&), (.~), (^.), (%~)) import qualified Data.ByteString.Char8 as B import Data.Functor () import Data.Maybe@@ -45,64 +45,65 @@              ,bsLogFileHandle :: Maybe SysIO.Handle              ,bsSelectedRemoteRepo :: Maybe RemoteRepo              ,bsRepoCache :: RepoCache-             ,bsProf :: [ProfilingEntry]              ,bsStartTime :: UTCTime              ,bsInheritStdIn :: Bool} -data ProfilingEntry-  = IoActionDuration NominalDiffTime-  | LogEvent LogLevel-             String-  deriving (Eq,Show)-- run :: MonadIO m => B9 a -> B9ConfigAction m a run action = do   cfg <- askRuntimeConfig   liftIO $ do-    buildId <- generateBuildId-    now     <- getCurrentTime-    withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)+    buildId <- liftIO $ generateBuildId+    now     <- liftIO $ getCurrentTime+    liftIO+      $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)  where+  resolveBuildDirRoot cfg = case _buildDirRoot cfg of+    Nothing    -> getCurrentDirectory >>= canonicalizePath+    Just root' -> do+      createDirectoryIfMissing True root'+      canonicalizePath root'   withLogFile cfg f = maybe     (f Nothing)     (\logf -> SysIO.withFile logf SysIO.AppendMode (f . Just))     (_logFile cfg)   withBuildDir cfg buildId =     bracket (createBuildDir cfg buildId) (removeBuildDir cfg)-  runImpl cfg buildId now buildDir logFileHandle =-    bracket getCurrentDirectory setCurrentDirectory $ \_ -> do-      traverse setCurrentDirectory (_buildDirRoot cfg)+  runImpl cfg buildId now buildDir logFileHandle = do       -- Check repositories-      repoCache <- initRepoCache-        (fromMaybe defaultRepositoryCache (_repositoryCache cfg))-      let buildDate = formatTime undefined "%F-%T" now-      remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)-      let-        ctx = BuildState buildId-                         buildDate-                         (cfg & remoteRepos .~ remoteRepos')-                         buildDir-                         logFileHandle-                         selectedRemoteRepo-                         repoCache-                         []-                         now-                         (_interactive cfg)-        selectedRemoteRepo = do-          sel <- _repository cfg-          lookupRemoteRepo remoteRepos' sel <|> error-            ( printf-              "selected remote repo '%s' not configured, valid remote repos are: '%s'"-              sel-              (show remoteRepos')-            )-      (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx-      -- Write a profiling report-      when (isJust (_profileFile cfg)) $ writeFile-        (fromJust (_profileFile cfg))-        (unlines $ show <$> reverse (bsProf ctxOut))-      return r+    repoCache <- initRepoCache+      (fromMaybe defaultRepositoryCache (_repositoryCache cfg))+    let buildDate = formatTime undefined "%F-%T" now+    remoteRepos'    <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)+    buildDirRootAbs <- resolveBuildDirRoot cfg+    let finalCfg =+          (  cfg+          &  remoteRepos+          .~ remoteRepos'+          &  buildDirRoot+          .~ Just buildDirRootAbs+          &  envVars+          %~ mappend [("buildDirRoot", buildDirRootAbs)]+          )+    let+      ctx = BuildState buildId+                       buildDate+                       finalCfg+                       buildDir+                       logFileHandle+                       selectedRemoteRepo+                       repoCache+                       now+                       (_interactive finalCfg)+      selectedRemoteRepo = do+        sel <- _repository cfg+        lookupRemoteRepo remoteRepos' sel <|> error+          ( printf+            "selected remote repo '%s' not configured, valid remote repos are: '%s'"+            sel+            (show remoteRepos')+          )+    (r, ctxOut) <- runStateT (runB9 wrappedAction) ctx+    return r   createBuildDir cfg buildId = if _uniqueBuildDirs cfg     then do       let subDir = "BUILD-" ++ buildId@@ -115,18 +116,18 @@       createDirectoryIfMissing True buildDir       canonicalizePath buildDir    where-    resolveBuildDir f = case _buildDirRoot cfg of-      Nothing    -> return f-      Just root' -> do-        createDirectoryIfMissing True root'-        root <- canonicalizePath root'-        return $ root </> f+    resolveBuildDir f = do+      root <- resolveBuildDirRoot cfg+      return $ root </> f   removeBuildDir cfg buildDir =     when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))       $ removeDirectoryRecursive buildDir   generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)   -- Run the action build action-  wrappedAction = do+  wrappedAction   = do+    b9cfg <- getConfig+    traverse (traceL . printf "Root Build Directory: %s")+             (b9cfg ^. buildDirRoot)     startTime <- gets bsStartTime     r         <- action     now       <- liftIO getCurrentTime@@ -158,22 +159,6 @@ getRepoCache :: B9 RepoCache getRepoCache = gets bsRepoCache --- getDownloader :: B9 Downloader--- getDownloader = gets bsDownloader------ -- | Configuration for a tool that retreives arbitrary URL and returns them to--- -- @stdout@.--- data Downloader =---   Downloader {downloaderCmd :: FilePath---              ,downloaderArgsBeforeUrl :: [String]---              ,downloaderUrlArgPrintfFormatString :: [String]---              ,downloaderArgsAfterUrl :: [String]}---   deriving (Read,Show,Eq,Ord,Typeable,Generic)------ readContentFromUrl :: String -> B9 B.ByteString--- readContentFromUrl url = do---   return expression- cmd :: String -> B9 () cmd str = do   inheritStdIn <- gets bsInheritStdIn@@ -225,14 +210,13 @@ errorL :: String -> B9 () errorL = b9Log LogError -errorExitL :: String -> B9 ()+errorExitL :: String -> B9 a errorExitL e = b9Log LogError e >> fail e  b9Log :: LogLevel -> String -> B9 () b9Log level msg = do   lv  <- gets $ _verbosity . bsCfg   lfh <- gets bsLogFileHandle-  modify $ \ctx -> ctx { bsProf = LogEvent level msg : bsProf ctx }   B9 $ liftIO $ logImpl lv lfh level msg  logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()@@ -262,10 +246,4 @@   deriving (Functor,Applicative,Monad,MonadState BuildState)  instance MonadIO B9 where-  liftIO m =-    do start <- B9 $ liftIO getCurrentTime-       res <- B9 $ liftIO m-       stop <- B9 $ liftIO getCurrentTime-       let durMS = IoActionDuration (stop `diffUTCTime` start)-       modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx}-       return res+  liftIO m = B9 $ liftIO m

@@ -25,12 +25,10 @@ import           Data.Text.Encoding as E import           Data.Text.Lazy.Encoding as LE import           Data.Text.Template (render,templateSafe,renderA)+import           System.IO.B9Extras import           Test.QuickCheck import           Text.Printf import           Text.Show.Pretty (ppShow)--import           Data.ConfigFile.B9Extras- import           B9.QCUtil -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents.

@@ -22,6 +22,10 @@                            ,pullLatestImage                            ,) where +import System.IO.Error (isDoesNotExistError)+import System.Directory (removeFile)+import System.IO.B9Extras (ensureDir, prettyPrintToFile, consult)+import Control.Lens ((^.)) import Control.Exception import Control.Monad import Control.Monad.IO.Class@@ -29,23 +33,28 @@ import System.FilePath import Text.Printf (printf) import Data.Maybe- import Data.Function- import Text.Show.Pretty (ppShow) import Data.List import Data.Data import Data.Generics.Schemes import Data.Generics.Aliases- import B9.B9Monad+import B9.B9Config import B9.Repository import B9.RepositoryIO import B9.DiskImages import qualified B9.PartitionTable as P-import Data.ConfigFile.B9Extras import B9.Content.StringTemplate +-- -- | Convert relative file paths of images, sources and mounted host directories+-- -- to absolute paths relative to '_buildDirRoot'.+-- makeImagePathsAbsoluteToBuildDirRoot :: ImageTarget -> B9 ImageTarget+-- makeImagePathsAbsoluteToBuildDirRoot img =+--   getConfig >>= maybe (return img) (return . go) . _buildDirRoot+--   where+--     go rootDir = everywhere mkAbs img+--       where mkAbs = mkT  -- | Replace $... variables inside an 'ImageTarget' substImageTarget :: [(String,String)] -> ImageTarget -> ImageTarget@@ -73,8 +82,8 @@      sub = subst env --- | Resolve an ImageSource to an 'Image'. Note however that this source will--- may not exist as is the case for 'EmptyImage'.+-- | Resolve an ImageSource to an 'Image'. The ImageSource might+-- not exist, as is the case for 'EmptyImage'. resolveImageSource :: ImageSource -> B9 Image resolveImageSource src =   case src of@@ -82,12 +91,14 @@       let img = Image fsLabel imgType fsType       in return (changeImageFormat imgType img)     (SourceImage srcImg _part _resize) ->-      liftIO (ensureAbsoluteImageDirExists srcImg)+      ensureAbsoluteImageDirExists srcImg     (CopyOnWrite backingImg) ->-      liftIO (ensureAbsoluteImageDirExists backingImg)-    (From name _resize) -> do-      latestImage <- getLatestImageByName (SharedImageName name)-      liftIO (ensureAbsoluteImageDirExists latestImage)+      ensureAbsoluteImageDirExists backingImg+    (From name _resize) ->+      getLatestImageByName (SharedImageName name)+        >>= maybe (errorExitL (printf "Nothing found for %s."+                                      (show (SharedImageName name))))+                  ensureAbsoluteImageDirExists  -- | Return all valid image types sorted by preference. preferredDestImageTypes :: ImageSource -> B9 [ImageType]@@ -103,10 +114,15 @@         (nub [fmt, Raw, QCow2, Vmdk]          `intersect`          allowedImageTypesForResize resize)-    (From name resize) -> do-      sharedImg <- getLatestImageByName (SharedImageName name)-      preferredDestImageTypes (SourceImage sharedImg NoPT resize)+    (From name resize) ->+      getLatestImageByName (SharedImageName name)+        >>= maybe (errorExitL (printf "Nothing found for %s."+                                       (show (SharedImageName name))))+                  (\sharedImg ->+                    preferredDestImageTypes (SourceImage sharedImg NoPT resize)) +-- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion'+-- in the preferred order. preferredSourceImageTypes :: ImageDestination -> [ImageType] preferredSourceImageTypes dest =   case dest of@@ -128,13 +144,24 @@     ShrinkToMinimum -> [Raw]     _ -> [Raw, QCow2, Vmdk] -ensureAbsoluteImageDirExists :: Image -> IO Image+-- | Create the parent directories for the file that contains the 'Image'.+-- If the path to the image file is relative, prepend '_buildDirRoot' from+-- the 'B9Config'.+ensureAbsoluteImageDirExists :: Image -> B9 Image ensureAbsoluteImageDirExists img@(Image path _ _) = do-  let dir = takeDirectory path-  createDirectoryIfMissing True dir-  dirAbs <- canonicalizePath dir-  return $ changeImageDirectory dirAbs img+  b9cfg <- getConfig+  let dir =+              let dirRel = takeDirectory path+              in if isRelative dirRel then+                    let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)+                    in prefix </> dirRel+                  else dirRel +  liftIO $ do+    createDirectoryIfMissing True dir+    dirAbs <- canonicalizePath dir+    return $ changeImageDirectory dirAbs img+ -- | Create an image from an image source. The destination image must have a -- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist.@@ -149,8 +176,12 @@     (CopyOnWrite backingImg) ->       createCOWImage backingImg dest     (From name resize) -> do-      sharedImg <- getLatestImageByName (SharedImageName name)-      materializeImageSource (SourceImage sharedImg NoPT resize) dest+      getLatestImageByName (SharedImageName name)+        >>= maybe (errorExitL (printf "Nothing found for %s."+                                       (show (SharedImageName name))))+                  (\sharedImg ->+                        materializeImageSource+                          (SourceImage sharedImg NoPT resize) dest)  createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 () createImageFromImage src part size out = do@@ -181,6 +212,8 @@                  outFile                  (imageFileExtension fmt)) +-- | Convert some 'Image', e.g. a temporary image used during the build phase+-- to the final destination. createDestinationImage :: Image -> ImageDestination -> B9 () createDestinationImage buildImg dest =     case dest of@@ -383,25 +416,29 @@   return (SharedImage name (SharedImageDate date) (SharedImageBuildId buildId) imgType imgFS)  -- | Convert the disk image and serialize the base image data structure.+-- If the 'maxLocalSharedImageRevisions' configuration is set to @Just n@+-- also delete all but the @n - 1@ newest images from the local cache. createSharedImageInCache :: Image -> SharedImageName -> B9 SharedImage createSharedImageInCache img sname@(SharedImageName name) = do   dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name)   sharedImg <- getSharedImageFromImageInfo sname img   dir <- getSharedImagesCacheDir   convertImage img (changeImageDirectory dir (sharedImageImage sharedImg))-  tell (dir </> sharedImageFileName sharedImg) sharedImg-  dbgL (printf "CREATED SHARED IMAGE IN CAHCE '%s'" (ppShow sharedImg))+  prettyPrintToFile (dir </> sharedImageFileName sharedImg) sharedImg+  dbgL (printf "CREATED SHARED IMAGE IN CACHE '%s'" (ppShow sharedImg))+  cleanOldSharedImageRevisionsFromCache sname   return sharedImg - -- | Publish the latest version of a shared image identified by name to the -- selected repository from the cache. pushSharedImageLatestVersion :: SharedImageName -> B9 ()-pushSharedImageLatestVersion name@(SharedImageName imgName) = do-  sharedImage <- getLatestSharedImageByNameFromCache name-  dbgL (printf "PUSHING '%s'" (ppShow sharedImage))-  pushToSelectedRepo sharedImage-  infoL (printf "PUSHED '%s'" imgName)+pushSharedImageLatestVersion name@(SharedImageName imgName) =+  getLatestSharedImageByNameFromCache name+    >>= maybe (errorExitL (printf "Nothing found for %s." (show imgName)))+              (\sharedImage -> do+                    dbgL (printf "PUSHING '%s'" (ppShow sharedImage))+                    pushToSelectedRepo sharedImage+                    infoL (printf "PUSHED '%s'" imgName))  -- | Upload a shared image from the cache to a selected remote repository pushToSelectedRepo :: SharedImage -> B9 ()@@ -428,13 +465,13 @@  -- | Pull the latest version of an image, either from the selected remote -- repo or from the repo that has the latest version.-pullLatestImage :: SharedImageName -> B9 Bool+pullLatestImage :: SharedImageName -> B9 (Maybe SharedImageBuildId) pullLatestImage name@(SharedImageName dbgName) = do   repos <- getSelectedRepos   let repoPredicate Cache = False       repoPredicate (Remote repoId) = repoId `elem` repoIds       repoIds = map remoteRepoRepoId repos-      hasName sharedImage = name == siName sharedImage+      hasName sharedImage = name == sharedImageName sharedImage   candidates <- lookupSharedImages repoPredicate hasName   let (Remote repoId, image) = last candidates   if null candidates@@ -442,7 +479,7 @@       errorL         (printf "No shared image named '%s' on these remote repositories: '%s'" dbgName            (ppShow repoIds))-      return False+      return Nothing     else do       dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image))       cacheDir <- getSharedImagesCacheDir@@ -456,28 +493,33 @@       pullFromRepo repo repoImgFile cachedImgFile       pullFromRepo repo repoInfoFile cachedInfoFile       infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId)-      return True-+      cleanOldSharedImageRevisionsFromCache name+      return (Just (sharedImageBuildId image))  -- | Return the 'Image' of the latest version of a shared image named 'name' -- from the local cache.-getLatestImageByName :: SharedImageName -> B9 Image+getLatestImageByName :: SharedImageName -> B9 (Maybe Image) getLatestImageByName name = do   sharedImage <- getLatestSharedImageByNameFromCache name   cacheDir <- getSharedImagesCacheDir-  let image = changeImageDirectory cacheDir (sharedImageImage sharedImage)-  dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show image))+  let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage+  case image of+    Just i ->+      dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))+    Nothing ->+      errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name))   return image  -- | Return the latest version of a shared image named 'name' from the local cache.-getLatestSharedImageByNameFromCache :: SharedImageName -> B9 SharedImage+getLatestSharedImageByNameFromCache :: SharedImageName -> B9 (Maybe SharedImage) getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do-  imgs <- lookupSharedImages (== Cache) ((== name) . siName)+  imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName)   case reverse imgs of     (Cache, sharedImage):_rest ->-      return sharedImage-    _ ->-      error (printf "No image(s) named '%s' found." dbgName)+      return (Just sharedImage)+    _ -> do+      errorL (printf "No image(s) named '%s' found." dbgName)+      return Nothing  -- | Return a list of all existing sharedImages from cached repositories. getSharedImages :: B9 [(Repository, [SharedImage])]@@ -530,3 +572,30 @@ getSharedImagesCacheDir = do   cacheDir <- localRepoDir <$> getRepoCache   return (cacheDir </> sharedImagesRootDirectory)++-- | Depending on the 'maxLocalSharedImageRevisions' 'B9Config' settings either+-- do nothing or delete all but the configured number of most recent shared+-- images with the given name from the local cache.+cleanOldSharedImageRevisionsFromCache :: SharedImageName -> B9 ()+cleanOldSharedImageRevisionsFromCache sn = do+    b9Cfg <- getConfig+    forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do+      toDelete <- take maxRevisions <$> newestSharedImages+      imgDir <- getSharedImagesCacheDir+      let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)+          infoFiles     = sharedImageFileName <$> toDelete+          imgFiles      = imageFileName . sharedImageImage <$> toDelete+      unless (null filesToDelete) $ do+          traceL (printf "DELETING %d OBSOLETE REVISIONS OF: %s"+                        (length filesToDelete) (show sn))+          mapM_ traceL filesToDelete+          mapM_ removeIfExists filesToDelete+   where+    newestSharedImages :: B9 [SharedImage]+    newestSharedImages =+      reverse . map snd <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName)++    removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists+     where+      handleExists e | isDoesNotExistError e = return ()+                     | otherwise             = throwIO e

@@ -295,16 +295,16 @@ -- * Constructors and accessors for 'SharedImage's  -- | Return the name of a shared image.-siName :: SharedImage -> SharedImageName-siName (SharedImage n _ _ _ _) = n+sharedImageName :: SharedImage -> SharedImageName+sharedImageName (SharedImage n _ _ _ _) = n --- | Return the date of a shared image.-siDate :: SharedImage -> SharedImageDate-siDate (SharedImage _ n _ _ _) = n+-- | Return the build date of a shared image.+sharedImageDate :: SharedImage -> SharedImageDate+sharedImageDate (SharedImage _ n _ _ _) = n  -- | Return the build id of a shared image.-siBuildId :: SharedImage -> SharedImageBuildId-siBuildId (SharedImage _ _ n _ _) = n+sharedImageBuildId :: SharedImage -> SharedImageBuildId+sharedImageBuildId (SharedImage _ _ n _ _) = n  -- | Print the contents of the shared image in one line prettyPrintSharedImages :: [SharedImage] -> String@@ -314,9 +314,9 @@       where         cols = [nameC, dateC, idC]           where-            nameC = col "Name" ((\(SharedImageName n) -> n) . siName)-            dateC = col "Date" ((\(SharedImageDate n) -> n) . siDate)-            idC = col "ID" ((\(SharedImageBuildId n) -> n) . siBuildId)+            nameC = col "Name" ((\(SharedImageName n) -> n) . sharedImageName)+            dateC = col "Date" ((\(SharedImageDate n) -> n) . sharedImageDate)+            idC = col "ID" ((\(SharedImageBuildId n) -> n) . sharedImageBuildId)             col title accessor =               (Boxes.text title) Boxes.// (Boxes.vcat Boxes.left cells)               where

@@ -11,15 +11,13 @@ import Text.Printf ( printf ) import Data.Char (toLower) import Control.Lens (view)- import B9.ShellScript import B9.B9Monad import B9.B9Config (libVirtLXCConfigs) import B9.DiskImages import B9.ExecEnv import B9.B9Config.LibVirtLXC as X-import Data.ConfigFile.B9Extras-+import System.IO.B9Extras (UUID(), randomUUID)  logLibVirtLXCConfig :: LibVirtLXCConfig -> B9 () logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)@@ -215,5 +213,3 @@  cpuCountStr :: ExecEnv -> String cpuCountStr = show . cpuCount . envResources--

@@ -21,7 +21,7 @@ import System.FilePath import System.Directory import B9.B9Config.Repository as X-import Data.ConfigFile.B9Extras+import System.IO.B9Extras  -- | Initialize the local repository cache directory. initRepoCache :: MonadIO m => SystemPath -> m RepoCache

@@ -10,9 +10,7 @@  import B9.Repository import B9.B9Monad-import Data.ConfigFile.B9Extras--+import System.IO.B9Extras (ensureDir) import Data.List import Control.Monad.IO.Class import System.Directory

@@ -58,7 +58,7 @@       srcImg <- resolveImageSource imageSource       let buildImg = changeImageFormat buildImgType                                        (changeImageDirectory buildDir srcImg)-      buildImgAbsolutePath <- liftIO (ensureAbsoluteImageDirExists buildImg)+      buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg       materializeImageSource imageSource buildImg       return buildImgAbsolutePath 

@@ -1,151 +1,91 @@-{-# Language DeriveDataTypeable #-}+{-# Language DeriveDataTypeable, ConstraintKinds #-} {-| Extensions to 'Data.ConfigFile' and utility functions for dealing with     configuration in general and reading/writing files. -}-module Data.ConfigFile.B9Extras ( allOn-                                , lastOn-                                , SystemPath (..)-                                , resolve-                                , ensureDir-                                , readIniFile-                                , getOptionM-                                , getOption-                                , getOptionOr-                                , IniFileException(..)-                                , module Data.ConfigFile-                                , UUID (..)-                                , randomUUID-                                , tell-                                , consult-                                , getDirectoryFiles-                                , maybeConsult-                                , maybeConsultSystemPath+module Data.ConfigFile.B9Extras ( addSectionCP+                                , setShowCP+                                , setCP+                                , readCP+                                , mergeCP+                                , toStringCP+                                , sectionsCP+                                , emptyCP+                                , type CPGet+                                , type CPOptionSpec+                                , type CPSectionSpec+                                , type CPDocument+                                , CPError()+                                , readCPDocument+                                , CPReadException(..)                                 ) where +#if !MIN_VERSION_base(4,10,0) import Data.Monoid-import Data.Function ( on )+#endif import Data.Typeable #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif-import Control.Exception-import Control.Monad.IO.Class-import System.Directory-import Text.Read ( readEither )-import System.Random ( randomIO )-import Data.Word ( Word16, Word32 )-import System.FilePath-import Text.Printf import Data.ConfigFile-import Data.Data-import Text.Show.Pretty (ppShow)+import Control.Exception+import Control.Monad.Except+import System.IO.B9Extras -allOn :: (a -> Maybe Bool) -> a -> a -> Maybe Bool-allOn getter x y = getAll <$> on mappend (fmap All . getter) x y+-- * Aliases for functions and types from 'ConfigParser' in 'Data.ConfigFile' -lastOn :: (a -> Maybe b) -> a -> a -> Maybe b-lastOn getter x y = getLast $ on mappend (Last . getter) x y+-- | An alias for  'ConfigParser'+type CPDocument = ConfigParser -data SystemPath = Path FilePath-                | InHomeDir FilePath-                | InB9UserDir FilePath-                | InTempDir FilePath-  deriving (Eq, Read, Show, Typeable, Data)+-- | An alias for 'SectionSpec'.+type CPSectionSpec = SectionSpec -resolve :: MonadIO m => SystemPath -> m FilePath-resolve (Path p) = return p-resolve (InHomeDir p) = liftIO $ do-  d <- getHomeDirectory-  return $ d </> p-resolve (InB9UserDir p) = liftIO $ do-  d <- getAppUserDataDirectory "b9"-  return $ d </> p-resolve (InTempDir p) = liftIO $ do-  d <- getTemporaryDirectory-  return $ d </> p+-- | An alias for 'OptionSpec'+type CPOptionSpec = OptionSpec --- | Get all files from 'dir' that is get ONLY files not directories-getDirectoryFiles :: MonadIO m => FilePath -> m [FilePath]-getDirectoryFiles dir = do-  entries <- liftIO (getDirectoryContents dir)-  fileEntries <- mapM (liftIO . doesFileExist . (dir </>)) entries-  return (snd <$> filter fst (fileEntries `zip` entries))+-- | An alias for 'setshow'.+setShowCP :: (Show a, MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> a -> m CPDocument+setShowCP = setshow -ensureDir :: MonadIO m => FilePath -> m ()-ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p)+-- | An alias for 'set'.+setCP :: (MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> String -> m CPDocument+setCP = set -data ReaderException = ReaderException FilePath String-  deriving (Show, Typeable)-instance Exception ReaderException+-- | An alias for 'get'.+readCP :: (CPGet a, MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> m a+readCP = get -tell :: (MonadIO m, Show a) => FilePath -> a -> m ()-tell f x = do-  ensureDir f-  liftIO (writeFile f (ppShow x))+-- | An alias for 'Get_C'+type CPGet a = Get_C a -consult :: (MonadIO m, Read a) => FilePath -> m a-consult f = liftIO $ do-  c <- readFile f-  case readEither c of-    Left e ->-      throwIO $ ReaderException f e-    Right a ->-      return a+-- | An alias for 'add_section'.+addSectionCP :: MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument+addSectionCP = add_section -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 consult f-    else return defaultArg+-- | An alias for 'merge'.+mergeCP :: CPDocument -> CPDocument -> CPDocument+mergeCP = merge -maybeConsultSystemPath :: (MonadIO m, Read a) => Maybe SystemPath -> a -> m a-maybeConsultSystemPath Nothing defaultArg = return defaultArg-maybeConsultSystemPath (Just f) defaultArg = liftIO $ do-  f' <- resolve f-  exists <- doesFileExist f'-  if exists-    then consult f'-    else return defaultArg+-- | An alias for 'to_string'+toStringCP :: CPDocument -> String+toStringCP = to_string -data IniFileException = IniFileException FilePath CPError-                      deriving (Show, Typeable)-instance Exception IniFileException+-- | An alias for 'sections'.+sectionsCP :: CPDocument -> [SectionSpec]+sectionsCP = sections -readIniFile :: MonadIO m => SystemPath -> m ConfigParser-readIniFile cfgFile' = do+-- * Reading a 'CPDocument' from a 'SystemPath'++-- | Read a file and try to parse the contents as a 'CPDocument', if something+-- goes wrong throw a 'CPReadException'+readCPDocument :: MonadIO m => SystemPath -> m CPDocument+readCPDocument cfgFile' = do   cfgFilePath <- resolve cfgFile'   liftIO $ do     res <- readfile emptyCP cfgFilePath     case res of-      Left e -> throwIO (IniFileException cfgFilePath e)+      Left e -> throwIO (CPReadException cfgFilePath 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--getOptionM :: (Read a) => ConfigParser -> SectionSpec -> OptionSpec -> Maybe a-getOptionM cp sec key = either (const Nothing) id $ get cp sec key--getOptionOr :: (Get_C a) => ConfigParser -> SectionSpec -> OptionSpec -> a -> a-getOptionOr cp sec key dv = either (const dv) id $ get cp sec key--newtype UUID = UUID (Word32, Word16, Word16, Word16, Word32, Word16)-             deriving (Read, Show, Eq, Ord)--instance PrintfArg UUID where-  formatArg (UUID (a, b, c, d, e, f)) fmt-    | fmtChar (vFmt 'U' fmt) == 'U' =-        let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String)-        in formatString str (fmt { fmtChar = 's', fmtPrecision = Nothing })-    | otherwise = errorBadFormat $ fmtChar fmt---randomUUID :: MonadIO m => m UUID-randomUUID = liftIO-               (UUID <$> ((,,,,,) <$> randomIO-                                  <*> randomIO-                                  <*> randomIO-                                  <*> randomIO-                                  <*> randomIO-                                  <*> randomIO))+-- | An exception thrown by 'readCPDocument'.+data CPReadException = CPReadException FilePath CPError+                      deriving (Show, Typeable)+instance Exception CPReadException

@@ -0,0 +1,118 @@+-- | Some utilities to deal with IO in B9.+module System.IO.B9Extras (SystemPath (..)+                                , resolve+                                , ensureDir+                                , getDirectoryFiles+                                , prettyPrintToFile+                                , consult+                                , ConsultException(..)+                                , randomUUID+                                 , UUID()+                                ) where++import Data.Typeable+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Exception+import Control.Monad.Except+import System.Directory+import Text.Read ( readEither )+import System.Random ( randomIO )+import Data.Word ( Word16, Word32 )+import System.FilePath+import Text.Printf+import Data.Data+import Text.Show.Pretty (ppShow)++-- * Relative Paths++-- | A data type encapsulating different kinds of relative or absolute paths.+data SystemPath = Path FilePath  -- ^ A path that will just be passed through+                | InHomeDir FilePath -- ^ A OS specific path relative to+                                      -- the home directory of a user.+                | InB9UserDir FilePath -- ^ A path relative to the @b9@ sub of+                                       -- the users application configuration+                                       -- directory 'getAppUserDataDirectory'+                | InTempDir FilePath -- ^ A path relative to the systems+                                     -- temporary directory.+  deriving (Eq, Read, Show, Typeable, Data)++-- | Convert a 'SystemPath' to a 'FilePath'.+resolve :: MonadIO m => SystemPath -> m FilePath+resolve (Path p) = return p+resolve (InHomeDir p) = liftIO $ do+  d <- getHomeDirectory+  return $ d </> p+resolve (InB9UserDir p) = liftIO $ do+  d <- getAppUserDataDirectory "b9"+  return $ d </> p+resolve (InTempDir p) = liftIO $ do+  d <- getTemporaryDirectory+  return $ d </> p++-- * File System Directory Utilities++-- | Get all files from 'dir' that is get ONLY files not directories+getDirectoryFiles :: MonadIO m => FilePath -> m [FilePath]+getDirectoryFiles dir = do+  entries <- liftIO (getDirectoryContents dir)+  fileEntries <- mapM (liftIO . doesFileExist . (dir </>)) entries+  return (snd <$> filter fst (fileEntries `zip` entries))++-- | Create all missing parent directories of a file path.+-- Note that the file path is assumed to be of a regular file, and+-- 'takeDirectory' is applied before creating the directory.+ensureDir :: MonadIO m => FilePath -> m ()+ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p)++-- * Reading and Writing from/to Files++-- | Write a value of a type that is an instance of 'Show' to file.+-- This function uses 'ppShow' instead of the given 'Show' instance.+prettyPrintToFile :: (MonadIO m, Show a) => FilePath -> a -> m ()+prettyPrintToFile f x = do+  ensureDir f+  liftIO (writeFile f (ppShow x))++-- | Read a value of a type that is an instance of 'Read' from a file.+-- This function throws a 'ConsultException' when the read the file failed.+consult :: (MonadIO m, Read a) => FilePath -> m a+consult f = liftIO $ do+  c <- readFile f+  case readEither c of+    Left e ->+      throwIO $ ConsultException f e+    Right a ->+      return a++-- | An 'Exception' thrown by 'consult' to indicate the file does not+-- contain a 'read'able String+data ConsultException = ConsultException FilePath String+  deriving (Show, Typeable)++instance Exception ConsultException++-- * Unique Random IDs++-- | A bunch of numbers, enough to make globally unique IDs. Create one of these+-- using 'randomUUID'.+newtype UUID = UUID (Word32, Word16, Word16, Word16, Word32, Word16)+             deriving (Read, Show, Eq, Ord)++instance PrintfArg UUID where+  formatArg (UUID (a, b, c, d, e, f)) fmt+    | fmtChar (vFmt 'U' fmt) == 'U' =+        let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String)+        in formatString str (fmt { fmtChar = 's', fmtPrecision = Nothing })+    | otherwise = errorBadFormat $ fmtChar fmt++-- | Generate a random 'UUID'.+randomUUID :: MonadIO m => m UUID+randomUUID = liftIO+               (UUID <$> ((,,,,,) <$> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO+                                  <*> randomIO))