b9-0.5.14: src/cli/Main.hs
module Main where
import Options.Applicative hiding (action)
import Options.Applicative.Help.Pretty hiding ((</>))
import Control.Exception
import Data.Function (on)
import Data.List (groupBy)
import Data.Maybe
import Data.Version
import Paths_b9
import System.Directory
import System.IO.Error hiding (isDoesNotExistErrorType)
#if !MIN_VERSION_base(4,8,0)
import System.IO.Error hiding (catch)
import Prelude hiding (catch)
#endif
import B9
main :: IO ()
main = do
b9Opts <- parseCommandLine
result <- runB9 b9Opts
exit result
where
exit success = when (not success) (exitWith (ExitFailure 128))
parseCommandLine :: IO B9Options
parseCommandLine =
execParser
(info
(helper <*> (B9Options <$> 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'" <>
headerDoc (Just helpHeader)))
where
helpHeader =
linebreak <>
text ("B9 - a benign VM-Image build tool v. " ++ b9Version)
data B9Options =
B9Options GlobalOpts
BuildAction
BuildVariables
data GlobalOpts = GlobalOpts
{ configFile :: Maybe SystemPath
, cliB9Config :: B9Config
}
type BuildAction = Maybe SystemPath -> ConfigParser -> B9Config -> IO Bool
runB9 :: B9Options -> IO Bool
runB9 (B9Options globalOpts action vars) = do
let cfgWithArgs =
cfgCli
{ envVars = envVars cfgCli ++ vars
}
cfgCli = cliB9Config globalOpts
cfgFile = configFile globalOpts
cp <- configure cfgFile cfgCli
action cfgFile cp cfgWithArgs
runShowVersion :: BuildAction
runShowVersion _cfgFile _cp _conf = do
putStrLn b9Version
return True
runBuildArtifacts :: [FilePath] -> BuildAction
runBuildArtifacts buildFiles _cfgFile cp conf = do
generators <- mapM consult buildFiles
buildArtifacts (mconcat generators) cp conf
runFormatBuildFiles :: [FilePath] -> BuildAction
runFormatBuildFiles buildFiles _cfgFile _cp _conf = do
generators <- mapM consult buildFiles
let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])
putStrLn `mapM` (generatorsFormatted)
(uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted)
return True
runPush :: SharedImageName -> BuildAction
runPush name _cfgFile cp conf = impl
where
conf' =
conf
{ keepTempDirs = False
}
impl =
run
cp
conf'
(if not (isJust (repository conf'))
then do
errorL
"No repository specified! Use '-r' to specify a repo BEFORE 'push'."
return False
else do
pushSharedImageLatestVersion name
return True)
runPull :: Maybe SharedImageName -> BuildAction
runPull mName _cfgFile cp conf =
run cp conf' (pullRemoteRepos >> maybePullImage)
where
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 =
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
case writeRemoteRepoConfig repo' cp of
Left er ->
error
(printf
"Failed to add remote repo '%s' to b9 configuration. The error was: \"%s\"."
(show repo)
(show er))
Right cpWithRepo -> writeB9Config cfgFile cpWithRepo
return True
globals :: Parser GlobalOpts
globals =
toGlobalOpts <$>
optional
(strOption
(help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <>
short 'c' <>
long "configuration-file" <>
metavar "FILENAME")) <*>
switch
(help "Log everything that happens to stdout" <> short 'v' <>
long "verbose") <*>
switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*>
optional
(strOption
(help "Path to a logfile" <> short 'l' <> long "log-file" <>
metavar "FILENAME")) <*>
optional
(strOption
(help "Output file for a command/timing profile" <>
long "profile-file" <>
metavar "FILENAME")) <*>
optional
(strOption
(help "Root directory for build directories" <> short 'b' <>
long "build-root-dir" <>
metavar "DIRECTORY")) <*>
switch
(help "Keep build directories after exit" <> short 'k' <>
long "keep-build-dir") <*>
switch
(help "Predictable build directory names" <> short 'u' <>
long "predictable-build-dir") <*>
optional
(strOption
(help
"Cache directory for shared images, default: '~/.b9/repo-cache'" <>
long "repo-cache" <>
metavar "DIRECTORY")) <*>
optional
(strOption
(help "Remote repository to share image to" <> short 'r' <>
long "repo" <>
metavar "REPOSITORY_ID"))
where
toGlobalOpts
:: Maybe FilePath
-> Bool
-> Bool
-> Maybe FilePath
-> Maybe FilePath
-> Maybe FilePath
-> Bool
-> Bool
-> Maybe FilePath
-> Maybe String
-> GlobalOpts
toGlobalOpts cfg verbose quiet logF profF buildRoot keep notUnique mRepoCache repo =
let minLogLevel =
if verbose
then Just LogTrace
else if quiet
then Just LogError
else Nothing
b9cfg' =
let b9cfg =
mempty
{ verbosity = minLogLevel
, logFile = logF
, profileFile = profF
, buildDirRoot = buildRoot
, keepTempDirs = keep
, uniqueBuildDirs = not notUnique
, repository = repo
}
in b9cfg
{ repositoryCache = Path <$> mRepoCache
}
in GlobalOpts
{ configFile = (Path <$> cfg) <|> pure defaultB9ConfigFile
, 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
"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 data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most 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 <*>
some
(strOption
(help
"Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <>
short 'f' <>
long "project-file" <>
metavar "FILENAME" <>
noArgError (ErrorMsg "No build file specified!")))
buildVars :: Parser BuildVariables
buildVars =
zip (("arg_" ++) . show <$> ([1 ..] :: [Int])) <$> many (strArgument idm)
remoteRepoParser :: Parser RemoteRepo
remoteRepoParser =
helper <*>
(RemoteRepo <$>
strArgument (help "The name of the remmote repository." <> metavar "NAME") <*>
strArgument
(help "The (remote) repository root path." <>
metavar "REMOTE_DIRECTORY") <*>
(SshPrivKey <$>
strArgument
(help
"Path to the SSH private key file used for authorization." <>
metavar "SSH_PRIV_KEY_FILE")) <*>
(SshRemoteHost <$>
((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>
argument
auto
(help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*>
(SshRemoteUser <$>
strArgument (help "SSH-User to login" <> metavar "USER")))
sharedImageNameParser :: Parser SharedImageName
sharedImageNameParser =
helper <*>
(SharedImageName <$>
strArgument (help "Shared image name" <> metavar "NAME"))
b9Version :: String
b9Version = showVersion version