diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -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 diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -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 <*> diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs --- a/src/lib/B9/B9Config.hs +++ b/src/lib/B9/B9Config.hs @@ -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)) diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs --- a/src/lib/B9/B9Monad.hs +++ b/src/lib/B9/B9Monad.hs @@ -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 diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs --- a/src/lib/B9/DiskImageBuilder.hs +++ b/src/lib/B9/DiskImageBuilder.hs @@ -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])] diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs --- a/src/lib/B9/DiskImages.hs +++ b/src/lib/B9/DiskImages.hs @@ -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 diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs --- a/src/lib/B9/Repository.hs +++ b/src/lib/B9/Repository.hs @@ -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. diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs --- a/src/lib/B9/RepositoryIO.hs +++ b/src/lib/B9/RepositoryIO.hs @@ -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