b9 0.5.8 → 0.5.9

raw patch · 8 files changed

+281/−65 lines, 8 filesdep +boxesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: boxes

API changes (from Hackage documentation)

Files

• b9.cabal +3/−1
• src/cli/Main.hs +185/−35
• src/lib/B9/B9Config.hs +5/−1
• src/lib/B9/B9Monad.hs +19/−13
• src/lib/B9/DiskImageBuilder.hs +15/−13
• src/lib/B9/DiskImages.hs +31/−2
• src/lib/B9/Repository.hs +18/−0
• src/lib/B9/RepositoryIO.hs +5/−0

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.8+version:             0.5.9  synopsis:            A tool and library for building virtual machine images. @@ -112,6 +112,7 @@                    , yaml                    , bifunctors                    , free+                   , boxes   default-extensions: TupleSections                     , GeneralizedNewtypeDeriving                     , DeriveDataTypeable@@ -129,6 +130,7 @@   -- other-extensions:   build-depends:     b9                    , base >= 4.7 && < 5+                   , directory                    , bytestring                    , optparse-applicative   hs-source-dirs:    src/cli

@@ -1,10 +1,17 @@ module Main where -import Options.Applicative hiding (action)-import Options.Applicative.Help.Pretty+import Options.Applicative             hiding (action)+import Options.Applicative.Help.Pretty hiding ((</>)) -import Paths_b9+import Control.Exception+import Data.Function                   (on)+import Data.List                       (groupBy)+import Data.Maybe import Data.Version+import Paths_b9+import Prelude                         hiding (catch)+import System.Directory+import System.IO.Error                 hiding (catch)  import B9 @@ -90,18 +97,121 @@     conf' = conf { keepTempDirs = False }     maybePullImage = maybe (return True) pullLatestImage mName +runRun :: SharedImageName -> [String] -> BuildAction+runRun (SharedImageName name) cmdAndArgs _cfgFile cp conf = impl+  where+    conf' =+        conf+        { keepTempDirs = False+        , interactive = True+        }+    impl = buildArtifacts runCmdAndArgs cp conf'+      where+        runCmdAndArgs =+            Artifact+                (IID ("run-" ++ name))+                (VmImages+                     [ ImageTarget+                           Transient+                           (From name KeepSize)+                           (MountPoint "/")]+                     (VmScript+                          X86_64+                          [SharedDirectory "." (MountPoint "/mnt/CWD")]+                          (Run (head cmdAndArgs') (tail cmdAndArgs'))))+        cmdAndArgs' =+            if null cmdAndArgs+                then ["/usr/bin/zsh"]+                else cmdAndArgs+++runGcLocalRepoCache :: BuildAction+runGcLocalRepoCache _cfgFile cp conf = impl+  where+    conf' =+        conf+        { keepTempDirs = False+        }+    impl =+        run cp conf' $+        do toDelete <-+               (obsoleteSharedmages . map snd) <$>+               lookupSharedImages (== Cache) (const True)+           imgDir <- getSharedImagesCacheDir+           let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)+               infoFiles = sharedImageFileName <$> toDelete+               imgFiles = (imageFileName . sharedImageImage) <$> toDelete+           if null filesToDelete+               then liftIO $+                    do putStrLn "\n\nNO IMAGES TO DELETE\n"+                       return True+               else liftIO $+                    do putStrLn "DELETING FILES:"+                       putStrLn (unlines filesToDelete)+                       mapM_ removeIfExists filesToDelete+                       return True+    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++runGcRemoteRepoCache :: BuildAction+runGcRemoteRepoCache _cfgFile cp conf = impl+  where+    conf' =+        conf+        { keepTempDirs = False+        }+    impl =+        run cp conf' $+        do repos <- getSelectedRepos+           cache <- getRepoCache+           mapM_ (cleanRemoteRepo cache) repos+           return True+ runListSharedImages :: BuildAction runListSharedImages _cfgFile cp conf = impl   where-    conf' = conf { keepTempDirs = False }-    impl = do-      imgs <- run cp conf' getSharedImages-      if null imgs-        then putStrLn "\n\nNO SHAREABLE IMAGES\n"-        else putStrLn "SHAREABLE IMAGES:"-      mapM_ (putStrLn . ppShow) imgs-      return True+    conf' =+        conf+        { keepTempDirs = False+        }+    impl =+        run cp conf' $+        do remoteRepo <- getSelectedRemoteRepo+           let repoPred =+                   maybe (== Cache) ((==) . toRemoteRepository) remoteRepo+           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."+               else liftIO $+                    putStrLn+                        ("Showing shared images on: " +++                         remoteRepoRepoId (fromJust remoteRepo))+           when (not (null allRepos)) $+               liftIO $+               do putStrLn "\nAvailable remote repositories:"+                  mapM_ (putStrLn . (" * " ++) . remoteRepoRepoId) allRepos+           imgs <- lookupSharedImages repoPred (const True)+           if null imgs+               then liftIO $ putStrLn "\n\nNO SHARED IMAGES\n"+               else liftIO $+                    do putStrLn ""+                       putStrLn $ prettyPrintSharedImages $ map snd imgs+           return True + runAddRepo :: RemoteRepo -> BuildAction runAddRepo repo cfgFile cp _conf = do   repo' <- remoteRepoCheckSshPrivKey repo@@ -189,21 +299,42 @@                     , cliB9Config = b9cfg' }  cmds :: Parser BuildAction-cmds = subparser (   command "version"-                               (info (pure runShowVersion)-                                     (progDesc "Show program version and exit."))-                  <> command "build"-                               (info (runBuildArtifacts <$> buildFileParser)-                                     (progDesc "Merge all build file and\-                                               \ generate all artifacts."))-                  <> command "push"-                        (info (runPush <$> sharedImageNameParser)-                              (progDesc "Push the lastest shared image\+cmds =+    subparser+        (command+             "version"+             (info+                  (pure runShowVersion)+                  (progDesc "Show program version and exit.")) <>+         command+             "build"+             (info+                  (runBuildArtifacts <$> buildFileParser)+                  (progDesc+                       "Merge all build file and\+                                               \ generate all artifacts.")) <>+         command+             "run"+             (info+                  (runRun <$> sharedImageNameParser <*> many (strArgument idm))+                  (progDesc+                       "Run a command on the lastest version of the\+                                        \ specified shared image. All modifications\+                                        \ are lost on exit.")) <>+         command+             "push"+             (info+                  (runPush <$> sharedImageNameParser)+                  (progDesc+                       "Push the lastest shared image\                                         \ from cache to the selected \-                                        \ remote repository."))-                  <> command "pull"-                             (info (runPull <$> optional sharedImageNameParser)-                                   (progDesc "Either pull shared image meta\+                                        \ remote repository.")) <>+         command+             "pull"+             (info+                  (runPull <$> optional sharedImageNameParser)+                  (progDesc+                       "Either pull shared image meta\                                              \ data from all repositories,\                                              \ or only from just a selected one.\                                              \ If additionally the name of a\@@ -211,16 +342,35 @@                                              \ pull the newest version\                                              \ from either the selected repo,\                                              \ or from the repo with the most\-                                             \ recent version."))-                  <> command "list"-                             (info (pure runListSharedImages)-                                   (progDesc "List shared images."))-                  <> command "add-repo"-                             (info (runAddRepo <$> remoteRepoParser)-                                   (progDesc "Add a remote repo."))-                  <> command "reformat"-                             (info (runFormatBuildFiles <$> buildFileParser)-                                   (progDesc "Re-Format all build files.")))+                                             \ recent version.")) <>+         command+             "clean-local"+             (info+                  (pure runGcLocalRepoCache)+                  (progDesc+                       "Remove old versions of shared images\+                                             \ from the local cache.")) <>+         command+             "clean-remote"+             (info+                  (pure runGcRemoteRepoCache)+                  (progDesc+                       "Remove cached meta-data of a remote repository. \+                       \If no '-r' is given, clean the meta data of ALL \+                       \remote repositories.")) <>+         command+             "list"+             (info (pure runListSharedImages) (progDesc "List shared images.")) <>+         command+             "add-repo"+             (info+                  (runAddRepo <$> remoteRepoParser)+                  (progDesc "Add a remote repo.")) <>+         command+             "reformat"+             (info+                  (runFormatBuildFiles <$> buildFileParser)+                  (progDesc "Re-Format all build files.")))  buildFileParser :: Parser [FilePath] buildFileParser = helper <*>

@@ -45,12 +45,13 @@                          , uniqueBuildDirs :: Bool                          , repositoryCache :: Maybe SystemPath                          , repository :: Maybe String+                         , interactive :: Bool                          } deriving (Show)   instance Monoid B9Config where   mempty = B9Config Nothing Nothing Nothing False LibVirtLXC Nothing [] True-                    Nothing Nothing+                    Nothing Nothing False   mappend c c' =     B9Config { verbosity = getLast $ on mappend (Last . verbosity) c c'              , logFile = getLast $ on mappend (Last . logFile) c c'@@ -62,6 +63,7 @@              , 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')              }  defaultB9Config :: B9Config@@ -75,6 +77,7 @@                            , uniqueBuildDirs = True                            , repository = Nothing                            , repositoryCache = Just defaultRepositoryCache+                           , interactive = False                            }  defaultRepositoryCache :: SystemPath@@ -170,6 +173,7 @@                  <*> getr uniqueBuildDirsK                  <*> getr repositoryCacheK                  <*> getr repositoryK+                 <*> pure False   in case getB9Config of        Left err ->          Left (printf "Failed to parse B9 configuration file: '%s'" (show err))

@@ -68,10 +68,11 @@     withBuildDir buildId = bracket (createBuildDir buildId) removeBuildDir      run' buildId now buildDir logFileHandle = do-      maybe (print "Keeping PWD as CWD") setCurrentDirectory (buildDirRoot cfg)+      maybe (return ()) setCurrentDirectory (buildDirRoot cfg)       -- Check repositories       repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (repositoryCache cfg))       let remoteRepos = getConfiguredRemoteRepos cfgParser+          buildDate = formatTime undefined "%F-%T" now       remoteRepos' <- mapM (initRemoteRepo repoCache) remoteRepos       let ctx = BuildState                   buildId@@ -85,8 +86,7 @@                   repoCache                   []                   now-                  True-          buildDate = formatTime undefined "%F-%T" now+                  (interactive cfg)           selectedRemoteRepo = do             sel <- repository cfg             lookupRemoteRepo remoteRepos sel@@ -171,28 +171,34 @@ cmd str = do   inheritStdIn <- gets bsInheritStdIn   if inheritStdIn-     then interactive str-     else nonInteractive str+     then interactiveCmd str+     else nonInteractiveCmd str -interactive :: String -> B9 ()-interactive str = void (cmdWithStdIn str :: B9 Inherited)+interactiveCmd :: String -> B9 ()+interactiveCmd str = void (cmdWithStdIn True str :: B9 Inherited) -nonInteractive :: String -> B9 ()-nonInteractive str = void (cmdWithStdIn str :: B9 ClosedStream)+nonInteractiveCmd :: String -> B9 ()+-- TODO if we use 'ClosedStream' we get an error from 'virsh console'+-- complaining about a missing controlling tty. Original source line:+-- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream)+nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 Inherited) -cmdWithStdIn :: (InputSource stdin) => String -> B9 stdin-cmdWithStdIn cmdStr = do+cmdWithStdIn :: (InputSource stdin) => Bool -> String -> B9 stdin+cmdWithStdIn toStdOut cmdStr = do   traceL $ "COMMAND: " ++ cmdStr-  (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)   cmdLogger <- getCmdLogger+  let outPipe = if toStdOut then CL.mapM_ B.putStr+                else cmdLogger LogTrace+  (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)   e <- liftIO $ runConcurrently $-         Concurrently (cpOut $$ cmdLogger LogTrace) *>+         Concurrently (cpOut $$ outPipe) *>          Concurrently (cpErr $$ cmdLogger LogInfo) *>          Concurrently (waitForStreamingProcess cph)   checkExitCode e   return cpIn    where+     getCmdLogger = do       lv <- gets $ verbosity . bsCfg       lfh <- gets bsLogFileHandle

@@ -16,6 +16,8 @@                            ,pushSharedImageLatestVersion                            ,lookupSharedImages                            ,getSharedImages+                           ,getSharedImagesCacheDir+                           ,getSelectedRepos                            ,pullRemoteRepos                            ,pullLatestImage                            ,) where@@ -84,7 +86,7 @@     (CopyOnWrite backingImg) ->       liftIO (ensureAbsoluteImageDirExists backingImg)     (From name _resize) -> do-      latestImage <- getLatestImageByName name+      latestImage <- getLatestImageByName (SharedImageName name)       liftIO (ensureAbsoluteImageDirExists latestImage)  -- | Return all valid image types sorted by preference.@@ -102,7 +104,7 @@          `intersect`          allowedImageTypesForResize resize)     (From name resize) -> do-      sharedImg <- getLatestImageByName name+      sharedImg <- getLatestImageByName (SharedImageName name)       preferredDestImageTypes (SourceImage sharedImg NoPT resize)  preferredSourceImageTypes :: ImageDestination -> [ImageType]@@ -134,7 +136,7 @@   return $ changeImageDirectory dirAbs img  -- | Create an image from an image source. The destination image must have a--- compatible image type and filesyste. The directory of the image MUST be+-- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist. materializeImageSource :: ImageSource -> Image -> B9 () materializeImageSource src dest =@@ -147,7 +149,7 @@     (CopyOnWrite backingImg) ->       createCOWImage backingImg dest     (From name resize) -> do-      sharedImg <- getLatestImageByName name+      sharedImg <- getLatestImageByName (SharedImageName name)       materializeImageSource (SourceImage sharedImg NoPT resize) dest  createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 ()@@ -364,8 +366,8 @@ -- | Publish the latest version of a shared image identified by name to the -- selected repository from the cache. pushSharedImageLatestVersion :: SharedImageName -> B9 ()-pushSharedImageLatestVersion (SharedImageName imgName) = do-  sharedImage <- getLatestSharedImageByNameFromCache imgName+pushSharedImageLatestVersion name@(SharedImageName imgName) = do+  sharedImage <- getLatestSharedImageByNameFromCache name   dbgL (printf "PUSHING '%s'" (ppShow sharedImage))   pushToSelectedRepo sharedImage   infoL (printf "PUSHED '%s'" imgName)@@ -396,7 +398,7 @@ -- | 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 name) = do+pullLatestImage name@(SharedImageName dbgName) = do   repos <- getSelectedRepos   let repoPredicate Cache = False       repoPredicate (Remote repoId) = repoId `elem` repoIds@@ -407,7 +409,7 @@   if null candidates     then do       errorL-        (printf "No shared image named '%s' on these remote repositories: '%s'" name+        (printf "No shared image named '%s' on these remote repositories: '%s'" dbgName            (ppShow repoIds))       return False     else do@@ -422,13 +424,13 @@           repo = fromJust (lookupRemoteRepo repos repoId)       pullFromRepo repo repoImgFile cachedImgFile       pullFromRepo repo repoInfoFile cachedInfoFile-      infoL (printf "PULLED '%s' FROM '%s'" name repoId)+      infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId)       return True   -- | Return the 'Image' of the latest version of a shared image named 'name' -- from the local cache.-getLatestImageByName :: String -> B9 Image+getLatestImageByName :: SharedImageName -> B9 Image getLatestImageByName name = do   sharedImage <- getLatestSharedImageByNameFromCache name   cacheDir <- getSharedImagesCacheDir@@ -437,14 +439,14 @@   return image  -- | Return the latest version of a shared image named 'name' from the local cache.-getLatestSharedImageByNameFromCache :: String -> B9 SharedImage-getLatestSharedImageByNameFromCache name = do+getLatestSharedImageByNameFromCache :: SharedImageName -> B9 SharedImage+getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do   imgs <- lookupSharedImages (== Cache) ((== name) . siName)   case reverse imgs of     (Cache, sharedImage):_rest ->       return sharedImage     _ ->-      error (printf "No image(s) named '%s' found." name)+      error (printf "No image(s) named '%s' found." dbgName)  -- | Return a list of all existing sharedImages from cached repositories. getSharedImages :: B9 [(Repository, [SharedImage])]

@@ -5,6 +5,7 @@ import Data.Semigroup import Data.Data import System.FilePath+import qualified Text.PrettyPrint.Boxes as Boxes  -- | Build target for disk images; the destination, format and size of the image -- to generate, as well as how to create or obtain the image before a@@ -92,6 +93,10 @@  type Mounted a = (a, MountPoint) +-- | Return the name of the file corresponding to an `Image`+imageFileName :: Image -> FilePath+imageFileName (Image f _ _) = f+ -- | Return the files generated for a local or a live image; shared and transient images -- are treated like they have no ouput files because the output files are manged -- by B9.@@ -143,9 +148,17 @@   deriving (Eq,Read,Show)  -- | Return the name of a shared image.-siName :: SharedImage -> String-siName (SharedImage (SharedImageName n) _ _ _ _) = n+siName :: SharedImage -> SharedImageName+siName (SharedImage n _ _ _ _) = n +-- | Return the date of a shared image.+siDate :: SharedImage -> SharedImageDate+siDate (SharedImage _ n _ _ _) = n++-- | Return the build id of a shared image.+siBuildId :: SharedImage -> SharedImageBuildId+siBuildId (SharedImage _ _ n _ _) = n+ -- | Shared images are orderd by name, build date and build id instance Ord SharedImage where   compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =@@ -154,6 +167,22 @@ newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show) newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show) newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show)++-- | Print the contents of the shared image in one line+prettyPrintSharedImages :: [SharedImage] -> String+prettyPrintSharedImages imgs = Boxes.render table+  where+    table = Boxes.hsep 1 Boxes.left cols+      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)+            col title accessor =+              (Boxes.text title) Boxes.// (Boxes.vcat Boxes.left cells)+              where+                cells = Boxes.text <$> accessor <$> imgs  -- | Return the disk image of an sharedImage sharedImageImage :: SharedImage -> Image

@@ -11,6 +11,7 @@                      ,SshRemoteUser(..)                      ,initRepoCache                      ,initRemoteRepo+                     ,cleanRemoteRepo                      ,remoteRepoCheckSshPrivKey                      ,remoteRepoCacheDir                      ,localRepoDir@@ -77,10 +78,27 @@                -> RemoteRepo                -> m RemoteRepo initRemoteRepo cache repo = do+  -- TODO logging traceL $ printf "Initializing remote repo: %s" (remoteRepoRepoId repo)   repo' <- remoteRepoCheckSshPrivKey repo   let (RemoteRepo repoId _ _ _ _) = repo'   ensureDir (remoteRepoCacheDir cache repoId ++ "/")   return repo'++-- | Empty the repository; load the corresponding settings from the config+-- file, check that the priv key exists and create the correspondig cache+-- directory.+cleanRemoteRepo :: MonadIO m+                  => RepoCache+                  -> RemoteRepo+                  -> m ()+cleanRemoteRepo cache repo = do+  let repoId = remoteRepoRepoId repo+      repoDir = remoteRepoCacheDir cache repoId ++ "/"+  -- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId+  ensureDir repoDir+  -- TODO logging traceL $ printf "Deleting directory: %s" repoDir+  liftIO $ removeDirectoryRecursive repoDir+  ensureDir repoDir  -- | Return the cache directory for a remote repository relative to the root -- cache dir.

@@ -5,6 +5,7 @@                        ,pullFromRepo                        ,pullGlob                        ,Repository(..)+                       ,toRemoteRepository                        ,FilePathGlob(..)) where  import B9.Repository@@ -20,6 +21,10 @@  data Repository = Cache | Remote String   deriving (Eq, Ord, Read, Show)++-- | Convert a `RemoteRepo` down to a mere `Repository`+toRemoteRepository :: RemoteRepo -> Repository+toRemoteRepository = Remote . remoteRepoRepoId  -- | Find files which are in 'subDir' and match 'glob' in the repository -- cache. NOTE: This operates on the repository cache, but does not enforce a