diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -87,35 +87,19 @@
* Configurable remote (ssh with pubkey auth + rsync) image shareing
* Local caching of shared images
-## Compilation from Source
-
-To build B9 first install:
-
-* `ghc` version 7.6 or higher
-* `cabal-install` version 1.16 or higher
-
-B9 uses stackage and cabal sandboxes. The build result can be found in
-`.cabal-sandbox/bin/`. To run a complete fresh build, execute:
-
- ./installDeps.sh
- cabal install
-
-To launch b9c run:
-
- ./build_and_run.sh
-
-To execute a ghci-repl run:
+## Installation
- cabal repl
+### b9 executable and library
-To execute unit tests run:
+Install via `stack`:
- ./build_and_test.sh
+ $ stack install b9
-## Installation
+### Runtime dependencies
-To be able to use B9 install
+To be able to use B9 install:
+* Linux
* lxc
* libvirt with lxc support (libvirt-driver-lxc, libvirt-daemon-lxc,...)
* virsh
diff --git a/b9.cabal b/b9.cabal
--- a/b9.cabal
+++ b/b9.cabal
@@ -1,5 +1,5 @@
name: b9
-version: 0.5.41
+version: 0.5.42
synopsis: A tool and library for building virtual machine images.
@@ -69,31 +69,37 @@
library
exposed-modules: B9
- , B9.B9Monad
+ , B9.ArtifactGenerator
+ , B9.ArtifactGeneratorImpl
, B9.B9Config
+ , B9.B9Config.LibVirtLXC
+ , B9.B9Config.Repository
+ , B9.B9Monad
, B9.Builder
- , B9.ConfigUtils
- , B9.ExecEnv
- , B9.DiskImages
+ , B9.Content.AST
+ , B9.Content.ErlangPropList
+ , B9.Content.ErlTerms
+ , B9.Content.Generator
+ , B9.Content.StringTemplate
+ , B9.Content.YamlObject
, B9.DiskImageBuilder
- , B9.ShellScript
- , B9.PartitionTable
- , B9.MBR
+ , B9.DiskImages
+ , B9.DSL
+ , B9.ExecEnv
+ , B9.Invokation
, B9.LibVirtLXC
+ , B9.MBR
+ , B9.PartitionTable
+ , B9.QCUtil
, B9.Repository
, B9.RepositoryIO
- , B9.ArtifactGenerator
- , B9.ArtifactGeneratorImpl
+ , B9.Shake
+ , B9.Shake.Actions
+ , B9.Shake.SharedImageRules
+ , B9.ShellScript
, B9.Vm
, B9.VmBuilder
- , B9.Content.ErlTerms
- , B9.Content.ErlangPropList
- , B9.Content.YamlObject
- , B9.Content.AST
- , B9.Content.Generator
- , B9.Content.StringTemplate
- , B9.QCUtil
- , B9.DSL
+ , Data.ConfigFile.B9Extras
other-modules: Paths_b9
-- other-extensions:
build-depends: ConfigFile >= 1.1.4
@@ -108,6 +114,7 @@
, directory >= 1.3
, filepath >= 1.4
, hashable >= 1.2
+ , lens >= 4
, mtl >= 2.2
, time >= 1.6
, parallel >= 3.2
@@ -116,6 +123,7 @@
, pretty >= 1.1
, process >= 1.4
, random >= 1.1
+ , shake >= 0.16 && < 0.17
, syb >= 0.6
, template >= 0.2
, text >= 1.2
@@ -157,6 +165,7 @@
, directory >= 1.3
, bytestring >= 0.10
, optparse-applicative >= 0.13
+ , lens >= 4
hs-source-dirs: src/cli
default-language: Haskell2010
default-extensions: TupleSections
diff --git a/src/cli/Main.hs b/src/cli/Main.hs
--- a/src/cli/Main.hs
+++ b/src/cli/Main.hs
@@ -2,281 +2,97 @@
import Options.Applicative hiding (action)
import Options.Applicative.Help.Pretty hiding (())
-
-import Control.Exception
-import Data.Function (on)
-import Data.Maybe
-import Data.Version
-import Paths_b9
-import System.Directory
-import System.IO.Error hiding (isDoesNotExistErrorType)
import B9
+import Control.Lens ((.~), (&))
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
+ b9Opts <- parseCommandLine
+ (_, result) <- runB9 b9Opts
+ exit result
+ where exit success = when (not success) (exitWith (ExitFailure 128))
-runListSharedImages :: BuildAction
-runListSharedImages _cfgFile cp conf = impl
+parseCommandLine :: IO (B9RunParameters ())
+parseCommandLine = execParser
+ ( info
+ (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'"
+ <> headerDoc (Just b9HelpHeader)
+ )
+ )
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
+ b9HelpHeader =
+ linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)
-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 :: Parser B9ConfigOverride
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"))
+ 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
@@ -289,101 +105,104 @@
-> 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'
- }
+ -> B9ConfigOverride
+ 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 = mempty & verbosity .~ minLogLevel
+ & logFile .~ logF
+ & profileFile .~ profF
+ & buildDirRoot .~ buildRoot
+ & keepTempDirs .~ keep
+ & uniqueBuildDirs .~ not notUnique
+ & repository .~ repo
+ & repositoryCache .~ (Path <$> mRepoCache)
-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.")))
+ in B9ConfigOverride
+ { _customB9ConfigPath = Path <$> cfg
+ , _customB9Config = b9cfg
+ }
+cmds :: Parser (B9Invokation ())
+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!")))
+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 =
@@ -391,30 +210,46 @@
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")))
+ 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"))
+ helper
+ <*> ( SharedImageName
+ <$> strArgument (help "Shared image name" <> metavar "NAME")
+ )
-b9Version :: String
-b9Version = showVersion version
diff --git a/src/lib/B9.hs b/src/lib/B9.hs
--- a/src/lib/B9.hs
+++ b/src/lib/B9.hs
@@ -11,11 +11,30 @@
-}
-module B9 (configure, b9_version, module X) where
+module B9 ( b9Version, b9VersionString
+ , B9RunParameters(..)
+ , runB9
+ , defaultB9RunParameters
+ , runShowVersion
+ , runBuildArtifacts
+ , runFormatBuildFiles
+ , runPush
+ , runPull
+ , runRun
+ , runGcLocalRepoCache
+ , runGcRemoteRepoCache
+ , runListSharedImages
+ , runAddRepo
+ , runLookupLocalSharedImage
+ , module X) where
import Control.Applicative as X
import Control.Monad as X
import Control.Monad.IO.Class as X
+import Control.Exception(throwIO, catch)
+import System.IO.Error (isDoesNotExistError)
+import System.Directory (removeFile)
import Data.Monoid as X
+import Data.IORef
import Data.List as X
import Data.Maybe as X
import Text.Show.Pretty as X (ppShow)
@@ -25,19 +44,195 @@
import Text.Printf as X (printf)
import Data.Version as X
import B9.Builder as X
+import B9.Invokation as X
import Paths_b9 (version)
-import qualified B9.LibVirtLXC as LibVirtLXC
-
--- | Merge 'existingConfig' with the configuration from the main b9 config
--- file. If the file does not exists, a new config file with the given
--- configuration will be written. The return value is a parser for the config
--- file. Returning the raw config file parser allows modules unkown to
--- 'B9.B9Config' to add their own values to the shared config file.
-configure :: MonadIO m => Maybe SystemPath -> B9Config -> m ConfigParser
-configure b9ConfigPath existingConfig = do
- writeInitialB9Config b9ConfigPath existingConfig LibVirtLXC.setDefaultConfig
- readB9Config b9ConfigPath
+import Data.Function (on)
+import Control.Lens as Lens ((^.), over, (.~), (%~), set)
-- | Return the cabal package version of the B9 library.
-b9_version :: Version
-b9_version = version
+b9Version :: Version
+b9Version = version
+
+-- | Return the cabal package version of the B9 library,
+-- formatted using `showVersion`.
+b9VersionString :: String
+b9VersionString = showVersion version
+
+-- | A data structure that contains the `B9Invokation`
+-- as well as build parameters.
+data B9RunParameters a =
+ B9RunParameters
+ B9ConfigOverride
+ (B9Invokation a)
+ BuildVariables
+
+-- | Run a b9 build.
+-- Return `True` if the build was successful.
+runB9 :: B9RunParameters a -> IO (a, Bool)
+runB9 (B9RunParameters overrides action vars) = do
+ invokeB9 $ do
+ modifyInvokationConfig
+ (over envVars (++ vars) . const (overrides ^. customB9Config))
+ mapM_ overrideB9ConfigPath (overrides ^. customB9ConfigPath)
+ action
+
+defaultB9RunParameters :: B9Invokation a -> B9RunParameters a
+defaultB9RunParameters ba =
+ B9RunParameters (B9ConfigOverride Nothing mempty) ba mempty
+
+runShowVersion :: B9Invokation ()
+runShowVersion = doAfterConfiguration $ do
+ liftIO $ putStrLn b9VersionString
+ return True
+
+runBuildArtifacts :: [FilePath] -> B9Invokation ()
+runBuildArtifacts buildFiles = do
+ generators <- mapM consult buildFiles
+ buildArtifacts (mconcat generators)
+
+runFormatBuildFiles :: [FilePath] -> B9Invokation ()
+runFormatBuildFiles buildFiles = doAfterConfiguration $ liftIO $ do
+ generators <- mapM consult buildFiles
+ let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])
+ putStrLn `mapM` (generatorsFormatted)
+ (uncurry writeFile) `mapM` (buildFiles `zip` generatorsFormatted)
+ return True
+
+runPush :: SharedImageName -> B9Invokation ()
+runPush name = do
+ modifyInvokationConfig (keepTempDirs .~ False)
+ run $ do
+ conf <- getConfig
+ if not (isJust (conf ^. repository))
+ 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 -> B9Invokation ()
+runPull mName = do
+ modifyInvokationConfig (keepTempDirs .~ False)
+ run (pullRemoteRepos >> maybePullImage)
+ where maybePullImage = maybe (return True) pullLatestImage mName
+
+runRun :: SharedImageName -> [String] -> B9Invokation ()
+runRun (SharedImageName name) cmdAndArgs = do
+ modifyInvokationConfig
+ (Lens.set keepTempDirs False . Lens.set interactive True)
+ buildArtifacts runCmdAndArgs
+ 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'))
+ )
+ )
+ where
+ cmdAndArgs' = if null cmdAndArgs then ["/usr/bin/zsh"] else cmdAndArgs
+
+
+runGcLocalRepoCache :: B9Invokation ()
+runGcLocalRepoCache = do
+ modifyInvokationConfig (keepTempDirs .~ False)
+ impl
+ where
+ impl = run $ 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 :: B9Invokation ()
+runGcRemoteRepoCache = do
+ modifyInvokationConfig (keepTempDirs .~ False)
+ run $ do
+ repos <- getSelectedRepos
+ cache <- getRepoCache
+ mapM_ (cleanRemoteRepo cache) repos
+ return True
+
+runListSharedImages :: B9Invokation ()
+runListSharedImages = do
+ modifyInvokationConfig (keepTempDirs .~ False)
+ run $ 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 -> B9Invokation ()
+runAddRepo repo = do
+ repo' <- remoteRepoCheckSshPrivKey repo
+ modifyPermanentConfig
+ ( remoteRepos
+ %~ ( mappend [repo']
+ . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId)
+ )
+ )
+
+runLookupLocalSharedImage
+ :: SharedImageName -> B9Invokation (Maybe SharedImageBuildId)
+runLookupLocalSharedImage n = do
+ ref <- liftIO (newIORef Nothing)
+ run (go ref)
+ liftIO (readIORef ref)
+ where
+ go ref = do
+ res <-
+ extractNewestImageFromResults
+ <$> lookupSharedImages isAvailableOnLocalHost hasTheDesiredName
+ liftIO $ writeIORef ref res
+ return True
+ where
+ extractNewestImageFromResults =
+ listToMaybe . map toBuildId . take 1 . reverse . map snd
+ where toBuildId (SharedImage _ _ i _ _) = i
+ isAvailableOnLocalHost = (Cache ==)
+ hasTheDesiredName (SharedImage n' _ _ _ _) = n == n'
+
diff --git a/src/lib/B9/ArtifactGeneratorImpl.hs b/src/lib/B9/ArtifactGeneratorImpl.hs
--- a/src/lib/B9/ArtifactGeneratorImpl.hs
+++ b/src/lib/B9/ArtifactGeneratorImpl.hs
@@ -9,7 +9,7 @@
import B9.VmBuilder
import B9.Vm
import B9.DiskImageBuilder
-import B9.ConfigUtils hiding (tell)
+import Data.ConfigFile.B9Extras hiding (tell)
import B9.Content.StringTemplate
import B9.Content.Generator
import B9.Content.AST
@@ -17,6 +17,7 @@
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
+import Control.Lens (view)
import Data.Data
import Data.Generics.Schemes
import Data.Generics.Aliases
@@ -50,7 +51,7 @@
-- | Run an artifact generator to produce the artifacts.
assemble :: ArtifactGenerator -> B9 [AssembledArtifact]
assemble artGen = do
- b9cfgEnvVars <- envVars <$> getConfig
+ b9cfgEnvVars <- view envVars <$> getConfig
buildId <- getBuildId
buildDate <- getBuildDate
case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of
@@ -273,7 +274,6 @@
liftIO (B.writeFile toAbs result)
sgChangePerm toAbs p
-
sgReadSourceFile :: [(String, String)] -> SourceFile -> B9 B.ByteString
sgReadSourceFile env = withEnvironment env . readTemplateFile
@@ -298,7 +298,6 @@
data SGPerm = SGSetPerm (Int, Int, Int)
| KeepPerm
deriving (Read, Show, Typeable, Data, Eq)
-
sgGetFroms :: SourceGenerator -> [SourceFile]
sgGetFroms (SG _ (SGFiles fs) _ _) = fs
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
@@ -3,30 +3,51 @@
The properties are independent of specific build targets.
-}
module B9.B9Config ( B9Config(..)
+ , verbosity
+ , logFile
+ , buildDirRoot
+ , keepTempDirs
+ , execEnvType
+ , profileFile
+ , envVars
+ , uniqueBuildDirs
+ , repositoryCache
+ , repository
+ , interactive
+ , libVirtLXCConfigs
+ , remoteRepos
+ , B9ConfigOverride(..)
+ , customB9Config
+ , customB9ConfigPath
, defaultB9ConfigFile
, defaultRepositoryCache
, defaultB9Config
- , getB9ConfigFile
- , writeB9Config
- , writeInitialB9Config
+ , openOrCreateB9Config
+ , writeB9ConfigParser
, readB9Config
, parseB9Config
+ , appendPositionalArguments
+ , modifyConfigParser
+ , b9ConfigToConfigParser
, LogLevel(..)
, ExecEnvType (..)
, BuildVariables
+ , module X
) where
import Data.Maybe (fromMaybe)
-import Control.Monad
import Control.Exception
import Data.Function (on)
import Control.Monad.IO.Class
import System.Directory
-import Text.Printf
import qualified Data.Semigroup as Sem
import Data.Monoid
-
-import B9.ConfigUtils
+import Data.List (partition, sortBy)
+import Data.ConfigFile.B9Extras
+import B9.B9Config.LibVirtLXC as X
+import B9.B9Config.Repository as X
+import Control.Lens.TH
+import Control.Monad ((>=>))
type BuildVariables = [(String,String)]
@@ -35,52 +56,96 @@
data LogLevel = LogTrace | LogDebug | LogInfo | LogError | LogNothing
deriving (Eq, Show, Ord, Read)
-data B9Config = B9Config { verbosity :: Maybe LogLevel
- , logFile :: Maybe FilePath
- , buildDirRoot :: Maybe FilePath
- , keepTempDirs :: Bool
- , execEnvType :: ExecEnvType
- , profileFile :: Maybe FilePath
- , envVars :: BuildVariables
- , uniqueBuildDirs :: Bool
- , repositoryCache :: Maybe SystemPath
- , repository :: Maybe String
- , interactive :: Bool
+data B9Config = B9Config { _verbosity :: Maybe LogLevel
+ , _logFile :: Maybe FilePath
+ , _buildDirRoot :: Maybe FilePath
+ , _keepTempDirs :: Bool
+ , _execEnvType :: ExecEnvType
+ , _profileFile :: Maybe FilePath
+ , _envVars :: BuildVariables
+ , _uniqueBuildDirs :: Bool
+ , _repositoryCache :: Maybe SystemPath
+ , _repository :: Maybe String
+ , _interactive :: Bool
+ , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig
+ , _remoteRepos :: [RemoteRepo]
} deriving (Show)
instance Sem.Semigroup B9Config where
c <> c' =
- B9Config { verbosity = getLast $ on mappend (Last . verbosity) c c'
- , logFile = getLast $ on mappend (Last . logFile) c c'
- , 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')
+ B9Config { _verbosity = getLast $ on mappend (Last . _verbosity) c c'
+ , _logFile = getLast $ on mappend (Last . _logFile) c c'
+ , _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')
+ , _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 Nothing False 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.
+data B9ConfigOverride = B9ConfigOverride
+ { _customB9ConfigPath :: Maybe SystemPath
+ , _customB9Config :: B9Config
+ }
+
+makeLenses ''B9Config
+makeLenses ''B9ConfigOverride
+
+-- | 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 cfgPath = do
+ cfgFile <- resolve (fromMaybe defaultB9ConfigFile cfgPath)
+ ensureDir cfgFile
+ liftIO $ do
+ exists <- doesFileExist cfgFile
+ if exists
+ then readIniFile (Path cfgFile)
+ else
+ let res = b9ConfigToConfigParser defaultB9Config emptyCP
+ in case res of
+ Left e -> throwIO (IniFileException cfgFile e)
+ Right cp -> writeFile cfgFile (to_string cp) >> return cp
+
+-- | Write the configuration in the 'ConfigParser' 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
+ cfgFile <- resolve (fromMaybe defaultB9ConfigFile cfgFileIn)
+ ensureDir cfgFile
+ liftIO (writeFile cfgFile (to_string 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
- }
+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 = []
+ }
defaultRepositoryCache :: SystemPath
defaultRepositoryCache = InB9UserDir "repo-cache"
@@ -109,75 +174,80 @@
cfgFileSection :: String
cfgFileSection = "global"
-getB9ConfigFile :: MonadIO m => Maybe SystemPath -> m FilePath
-getB9ConfigFile mCfgFile = do
- cfgFile <- resolve (fromMaybe defaultB9ConfigFile mCfgFile)
- ensureDir cfgFile
- return cfgFile
-
-writeB9Config :: MonadIO m
- => Maybe SystemPath
- -> ConfigParser
- -> m ()
-writeB9Config cfgFileIn cp = do
- cfgFile <- getB9ConfigFile cfgFileIn
- liftIO (writeFile cfgFile (to_string cp))
+-- | Parse a 'B9Config', modify it, and merge it back to the given 'ConfigParser'.
+modifyConfigParser
+ :: (B9Config -> B9Config) -> ConfigParser -> Either CPError ConfigParser
+modifyConfigParser f cp = do
+ cfg <- parseB9Config cp
+ cp2 <- b9ConfigToConfigParser (f cfg) emptyCP
+ return (merge cp cp2)
-writeInitialB9Config :: MonadIO m
- => Maybe SystemPath
- -> B9Config
- -> ConfigParser
- -> m ()
-writeInitialB9Config Nothing cliCfg cpNonGlobal = writeInitialB9Config
- (Just defaultB9ConfigFile)
- cliCfg
- cpNonGlobal
-writeInitialB9Config (Just cfgPath) cliCfg cpNonGlobal = do
- cfgFile <- resolve cfgPath
- ensureDir cfgFile
- exists <- liftIO $ doesFileExist cfgFile
- unless exists $
- let res = do
- let cp = emptyCP
- c = defaultB9Config <> cliCfg
- cp1 <- add_section cp 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)
- cpB <- setshow cpA cfgFileSection repositoryK (repository c)
- return $ merge cpB cpNonGlobal
- in case res of
- Left e -> liftIO (throwIO (IniFileException cfgFile e))
- Right cp -> liftIO (writeFile cfgFile (to_string cp))
+-- | Append a config file section for the 'B9Config' to a 'ConfigParser'.
+b9ConfigToConfigParser
+ :: B9Config -> ConfigParser -> Either CPError ConfigParser
+b9ConfigToConfigParser c cp = do
+ cp1 <- add_section cp 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)
+ cpB <-
+ ( foldr (>=>)
+ return
+ (libVirtLXCConfigToConfigParser <$> (_libVirtLXCConfigs c))
+ )
+ cpA
+ cpFinal <- (foldr (>=>) return (remoteRepoToConfigParser <$> _remoteRepos c))
+ cpB
+ setshow cpFinal cfgFileSection repositoryK (_repository c)
readB9Config :: MonadIO m => Maybe SystemPath -> m ConfigParser
-readB9Config Nothing = readB9Config (Just defaultB9ConfigFile)
-readB9Config (Just cfgFile) = readIniFile cfgFile
+readB9Config cfgFile = readIniFile (fromMaybe defaultB9ConfigFile cfgFile)
-parseB9Config :: ConfigParser -> Either String B9Config
+parseB9Config :: ConfigParser -> 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
- in case getB9Config of
- Left err ->
- Left (printf "Failed to parse B9 configuration file: '%s'" (show err))
- Right x ->
- Right x
+ 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
+
+
+-- | If environment variables @arg_1 .. arg_n@ are bound
+-- and a list of @k@ additional values are passed to this function,
+-- store them with keys @arg_(n+1) .. arg_(n+k)@.
+appendPositionalArguments :: [String] -> B9Config -> B9Config
+appendPositionalArguments extraPositional c = c
+ { _envVars = appendVars (_envVars c)
+ }
+ where
+ appendVars argsOld =
+ let (oldPositional, oldOther) =
+ partition (("arg_" ==) . take 4 . fst) argsOld
+ oldPositionalSortedByPosition =
+ map snd
+ $ sortBy (compare `on` fst)
+ $ map (\(x, y) -> ((read :: String -> Int) $ drop 4 $ x, y))
+ $ oldPositional
+ newPositional =
+ let xs = oldPositionalSortedByPosition ++ extraPositional
+ in [ ("arg_" ++ show i, a) | (i, a) <- zip [1 :: Int ..] xs ]
+ in newPositional ++ oldOther
diff --git a/src/lib/B9/B9Config/LibVirtLXC.hs b/src/lib/B9/B9Config/LibVirtLXC.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/B9Config/LibVirtLXC.hs
@@ -0,0 +1,128 @@
+module B9.B9Config.LibVirtLXC (
+ libVirtLXCConfigToConfigParser
+ , defaultLibVirtLXCConfig
+ , parseLibVirtLXCConfig
+ , LibVirtLXCConfig(..)
+ , LXCGuestCapability(..)
+ ) where
+
+import B9.DiskImages
+import B9.ExecEnv
+import Data.ConfigFile.B9Extras
+
+
+data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool
+ , virshPath :: FilePath
+ , emulator :: FilePath
+ , virshURI :: FilePath
+ , networkId :: Maybe String
+ , guestCapabilities :: [LXCGuestCapability]
+ , guestRamSize :: RamSize
+ } deriving (Read, Show)
+
+-- | Available linux capabilities for lxc containers. This maps directly to the
+-- capabilities defined in 'man 7 capabilities'.
+data LXCGuestCapability = CAP_MKNOD
+ | CAP_AUDIT_CONTROL
+ | CAP_AUDIT_READ
+ | CAP_AUDIT_WRITE
+ | CAP_BLOCK_SUSPEND
+ | CAP_CHOWN
+ | CAP_DAC_OVERRIDE
+ | CAP_DAC_READ_SEARCH
+ | CAP_FOWNER
+ | CAP_FSETID
+ | CAP_IPC_LOCK
+ | CAP_IPC_OWNER
+ | CAP_KILL
+ | CAP_LEASE
+ | CAP_LINUX_IMMUTABLE
+ | CAP_MAC_ADMIN
+ | CAP_MAC_OVERRIDE
+ | CAP_NET_ADMIN
+ | CAP_NET_BIND_SERVICE
+ | CAP_NET_BROADCAST
+ | CAP_NET_RAW
+ | CAP_SETGID
+ | CAP_SETFCAP
+ | CAP_SETPCAP
+ | CAP_SETUID
+ | CAP_SYS_ADMIN
+ | CAP_SYS_BOOT
+ | CAP_SYS_CHROOT
+ | CAP_SYS_MODULE
+ | CAP_SYS_NICE
+ | CAP_SYS_PACCT
+ | CAP_SYS_PTRACE
+ | CAP_SYS_RAWIO
+ | CAP_SYS_RESOURCE
+ | CAP_SYS_TIME
+ | CAP_SYS_TTY_CONFIG
+ | CAP_SYSLOG
+ | CAP_WAKE_ALARM
+ deriving (Read, Show)
+
+defaultLibVirtLXCConfig :: LibVirtLXCConfig
+defaultLibVirtLXCConfig = LibVirtLXCConfig
+ True
+ "/usr/bin/virsh"
+ "/usr/lib/libvirt/libvirt_lxc"
+ "lxc:///"
+ Nothing
+ [ CAP_MKNOD
+ , CAP_SYS_ADMIN
+ , CAP_SYS_CHROOT
+ , CAP_SETGID
+ , CAP_SETUID
+ , CAP_NET_BIND_SERVICE
+ , CAP_SETPCAP
+ , CAP_SYS_PTRACE
+ , CAP_SYS_MODULE
+ ]
+ (RamSize 1 GB)
+
+cfgFileSection :: String
+cfgFileSection = "libvirt-lxc"
+useSudoK :: String
+useSudoK = "use_sudo"
+virshPathK :: String
+virshPathK = "virsh_path"
+emulatorK :: String
+emulatorK = "emulator_path"
+virshURIK :: String
+virshURIK = "connection"
+networkIdK :: String
+networkIdK = "network"
+guestCapabilitiesK :: String
+guestCapabilitiesK = "guest_capabilities"
+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
+
+parseLibVirtLXCConfig :: ConfigParser -> Either CPError LibVirtLXCConfig
+parseLibVirtLXCConfig cp =
+ let getr :: (Get_C a) => OptionSpec -> Either CPError a
+ getr = get cp cfgFileSection
+ in LibVirtLXCConfig
+ <$> (getr useSudoK)
+ <*> (getr virshPathK)
+ <*> (getr emulatorK)
+ <*> (getr virshURIK)
+ <*> (getr networkIdK)
+ <*> (getr guestCapabilitiesK)
+ <*> (getr guestRamSizeK)
+
+
+
+
diff --git a/src/lib/B9/B9Config/Repository.hs b/src/lib/B9/B9Config/Repository.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/B9Config/Repository.hs
@@ -0,0 +1,90 @@
+module B9.B9Config.Repository ( RemoteRepo(..)
+ , remoteRepoRepoId
+ , RepoCache(..)
+ , SshPrivKey(..)
+ , SshRemoteHost(..)
+ , SshRemoteUser(..)
+ , remoteRepoToConfigParser
+ , parseRemoteRepos
+ ) where
+
+import Data.Data
+import Data.List (isSuffixOf)
+import Data.ConfigFile
+
+newtype RepoCache = RepoCache FilePath
+ deriving (Read, Show, Typeable, Data)
+
+data RemoteRepo = RemoteRepo String
+ FilePath
+ SshPrivKey
+ SshRemoteHost
+ SshRemoteUser
+ deriving (Read, Show, Typeable, Data)
+
+remoteRepoRepoId :: RemoteRepo -> String
+remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId
+
+newtype SshPrivKey = SshPrivKey FilePath
+ deriving (Read, Show, Typeable, Data)
+
+newtype SshRemoteHost = SshRemoteHost (String,Int)
+ deriving (Read, Show, Typeable, Data)
+
+newtype SshRemoteUser = SshRemoteUser String
+ deriving (Read, Show, Typeable, Data)
+
+
+-- | 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
+
+-- | Load a repository from a configuration file that has been written by
+-- 'writeRepositoryToB9Config'.
+parseRemoteRepos :: ConfigParser -> 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
+
+repoSectionSuffix :: String
+repoSectionSuffix = "-repo"
+repoRemotePathK :: String
+repoRemotePathK = "remote_path"
+repoRemoteSshKeyK :: String
+repoRemoteSshKeyK = "ssh_priv_key_file"
+repoRemoteSshHostK :: String
+repoRemoteSshHostK = "ssh_remote_host"
+repoRemoteSshPortK :: String
+repoRemoteSshPortK = "ssh_remote_port"
+repoRemoteSshUserK :: String
+repoRemoteSshUserK = "ssh_remote_user"
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
@@ -7,19 +7,21 @@
This module is used by the _effectful_ functions in this library.
-}
module B9.B9Monad
- (B9, run, traceL, dbgL, infoL, errorL, getConfigParser, getConfig,
+ (B9, run, traceL, dbgL, infoL, errorL, getConfig,
getBuildId, getBuildDate, getBuildDir, getExecEnvType,
getSelectedRemoteRepo, getRemoteRepos, getRepoCache, cmd)
where
import B9.B9Config
-import B9.ConfigUtils
+import B9.Invokation
import B9.Repository
import Control.Applicative
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State
+import Control.Monad.Reader(ask)
+import Control.Lens((&), (.~))
import qualified Data.ByteString.Char8 as B
import Data.Functor ()
import Data.Maybe
@@ -40,12 +42,10 @@
data BuildState =
BuildState {bsBuildId :: String
,bsBuildDate :: String
- ,bsCfgParser :: ConfigParser
,bsCfg :: B9Config
,bsBuildDir :: FilePath
,bsLogFileHandle :: Maybe SysIO.Handle
,bsSelectedRemoteRepo :: Maybe RemoteRepo
- ,bsRemoteRepos :: [RemoteRepo]
,bsRepoCache :: RepoCache
,bsProf :: [ProfilingEntry]
,bsStartTime :: UTCTime
@@ -57,84 +57,82 @@
String
deriving (Eq,Show)
-run :: ConfigParser -> B9Config -> B9 a -> IO a
-run cfgParser cfg action =
- do buildId <- generateBuildId
- now <- getCurrentTime
- withBuildDir buildId
- (withLogFile . run' buildId now)
- where withLogFile f =
- maybe (f Nothing)
- (\logf ->
- SysIO.withFile logf
- SysIO.AppendMode
- (f . Just))
- (logFile cfg)
- withBuildDir buildId = bracket (createBuildDir buildId) removeBuildDir
- run' buildId now buildDir logFileHandle =
- do 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
- buildDate
- cfgParser
- cfg
- buildDir
- logFileHandle
- selectedRemoteRepo
- remoteRepos'
- 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
- createBuildDir buildId =
- if uniqueBuildDirs cfg
- then do let subDir = "BUILD-" ++ buildId
- buildDir <- resolveBuildDir subDir
- createDirectory buildDir
- canonicalizePath buildDir
- else do let subDir = "BUILD-" ++ buildId
- buildDir <- resolveBuildDir subDir
- 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
- removeBuildDir buildDir =
- when (uniqueBuildDirs cfg && not (keepTempDirs cfg)) $
- removeDirectoryRecursive buildDir
- generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)
- -- Run the action build action
- wrappedAction =
- do startTime <- gets bsStartTime
- r <- action
- now <- liftIO getCurrentTime
- let duration = show (now `diffUTCTime` startTime)
- infoL (printf "DURATION: %s" duration)
- return r
+run :: B9 Bool -> B9Invokation ()
+run action = doAfterConfiguration $ do
+ cfg <- ask
+ liftIO $ do
+ buildId <- generateBuildId
+ now <- getCurrentTime
+ withBuildDir cfg buildId (withLogFile cfg . run' cfg buildId now)
+ where
+ 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)
+ run' cfg buildId now buildDir logFileHandle = do
+ maybe (return ()) setCurrentDirectory (_buildDirRoot cfg)
+ -- 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
+ createBuildDir cfg buildId = if _uniqueBuildDirs cfg
+ then do
+ let subDir = "BUILD-" ++ buildId
+ buildDir <- resolveBuildDir subDir
+ createDirectory buildDir
+ canonicalizePath buildDir
+ else do
+ let subDir = "BUILD-" ++ buildId
+ buildDir <- resolveBuildDir subDir
+ 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
+ removeBuildDir cfg buildDir =
+ when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg))
+ $ removeDirectoryRecursive buildDir
+ generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)
+ -- Run the action build action
+ wrappedAction = do
+ startTime <- gets bsStartTime
+ r <- action
+ now <- liftIO getCurrentTime
+ let duration = show (now `diffUTCTime` startTime)
+ infoL (printf "DURATION: %s" duration)
+ return r
getBuildId :: B9 FilePath
getBuildId = gets bsBuildId
@@ -145,20 +143,17 @@
getBuildDir :: B9 FilePath
getBuildDir = gets bsBuildDir
-getConfigParser :: B9 ConfigParser
-getConfigParser = gets bsCfgParser
-
getConfig :: B9 B9Config
getConfig = gets bsCfg
getExecEnvType :: B9 ExecEnvType
-getExecEnvType = gets (execEnvType . bsCfg)
+getExecEnvType = gets (_execEnvType . bsCfg)
getSelectedRemoteRepo :: B9 (Maybe RemoteRepo)
getSelectedRemoteRepo = gets bsSelectedRemoteRepo
getRemoteRepos :: B9 [RemoteRepo]
-getRemoteRepos = gets bsRemoteRepos
+getRemoteRepos = gets (_remoteRepos . bsCfg)
getRepoCache :: B9 RepoCache
getRepoCache = gets bsRepoCache
@@ -180,11 +175,9 @@
-- return expression
cmd :: String -> B9 ()
-cmd str =
- do inheritStdIn <- gets bsInheritStdIn
- if inheritStdIn
- then interactiveCmd str
- else nonInteractiveCmd str
+cmd str = do
+ inheritStdIn <- gets bsInheritStdIn
+ if inheritStdIn then interactiveCmd str else nonInteractiveCmd str
interactiveCmd :: String -> B9 ()
interactiveCmd str = void (cmdWithStdIn True str :: B9 Inherited)
@@ -195,32 +188,30 @@
-- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream)
nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 Inherited)
-cmdWithStdIn :: (InputSource stdin)
- => Bool -> String -> B9 stdin
-cmdWithStdIn toStdOut cmdStr =
- do traceL $ "COMMAND: " ++ 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 $$ outPipe) *>
- Concurrently (cpErr $$ cmdLogger LogInfo) *>
- Concurrently (waitForStreamingProcess cph)
- checkExitCode e
- return cpIn
- where getCmdLogger =
- do lv <- gets $ verbosity . bsCfg
- lfh <- gets bsLogFileHandle
- return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack)
- checkExitCode ExitSuccess = traceL "COMMAND SUCCESS"
- checkExitCode ec@(ExitFailure e) =
- do errorL $ printf "COMMAND '%s' FAILED: %i!" cmdStr e
- liftIO $ exitWith ec
+cmdWithStdIn :: (InputSource stdin) => Bool -> String -> B9 stdin
+cmdWithStdIn toStdOut cmdStr = do
+ traceL $ "COMMAND: " ++ 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 $$ outPipe)
+ *> Concurrently (cpErr $$ cmdLogger LogInfo)
+ *> Concurrently (waitForStreamingProcess cph)
+ checkExitCode e
+ return cpIn
+ where
+ getCmdLogger = do
+ lv <- gets $ _verbosity . bsCfg
+ lfh <- gets bsLogFileHandle
+ return $ \level -> CL.mapM_ (logImpl lv lfh level . B.unpack)
+ checkExitCode ExitSuccess =
+ traceL $ printf "COMMAND '%s' exited with exit code: 0" cmdStr
+ checkExitCode ec@(ExitFailure e) = do
+ errorL $ printf "COMMAND '%s' exited with exit code: %i" cmdStr e
+ liftIO $ exitWith ec
traceL :: String -> B9 ()
traceL = b9Log LogTrace
@@ -235,37 +226,33 @@
errorL = b9Log LogError
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
+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 ()
-logImpl minLevel mh level msg =
- do lm <- formatLogMsg level msg
- when (isJust minLevel && level >= fromJust minLevel)
- (putStr lm)
- when (isJust mh) $
- do SysIO.hPutStr (fromJust mh)
- lm
- SysIO.hFlush (fromJust mh)
+logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()
+logImpl minLevel mh level msg = do
+ lm <- formatLogMsg level msg
+ when (isJust minLevel && level >= fromJust minLevel) (putStr lm)
+ when (isJust mh) $ do
+ SysIO.hPutStr (fromJust mh) lm
+ SysIO.hFlush (fromJust mh)
formatLogMsg :: LogLevel -> String -> IO String
-formatLogMsg l msg =
- do utct <- getCurrentTime
- let time = formatTime defaultTimeLocale "%H:%M:%S" utct
- return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg
+formatLogMsg l msg = do
+ utct <- getCurrentTime
+ let time = formatTime defaultTimeLocale "%H:%M:%S" utct
+ return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg
printLevel :: LogLevel -> String
-printLevel l =
- case l of
- LogNothing -> "NOTHING"
- LogError -> " ERROR "
- LogInfo -> " INFO "
- LogDebug -> " DEBUG "
- LogTrace -> " TRACE "
+printLevel l = case l of
+ LogNothing -> "NOTHING"
+ LogError -> " ERROR "
+ LogInfo -> " INFO "
+ LogDebug -> " DEBUG "
+ LogTrace -> " TRACE "
newtype B9 a =
B9 {runB9 :: StateT BuildState IO a}
@@ -279,3 +266,7 @@
let durMS = IoActionDuration (stop `diffUTCTime` start)
modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx}
return res
+
+
+
+
diff --git a/src/lib/B9/Builder.hs b/src/lib/B9/Builder.hs
--- a/src/lib/B9/Builder.hs
+++ b/src/lib/B9/Builder.hs
@@ -4,11 +4,12 @@
-}
module B9.Builder (buildArtifacts, module X) where
import B9.B9Monad as X
-import B9.ConfigUtils as X
+import Data.ConfigFile.B9Extras as X
import B9.B9Config as X
import B9.ExecEnv as X
import B9.DiskImages as X
import B9.DiskImageBuilder as X
+import B9.Invokation as X
import B9.ShellScript as X
import B9.Repository as X
import B9.RepositoryIO as X
@@ -24,32 +25,16 @@
import B9.Content.YamlObject as X
import B9.Content.Generator as X
-import Data.Semigroup as Sem
import Text.Printf ( printf )
import Text.Show.Pretty (ppShow)
import Control.Monad.IO.Class
import System.Directory
-buildArtifacts :: ArtifactGenerator -> ConfigParser -> B9Config -> IO Bool
-buildArtifacts artifactGenerator cfgParser cliCfg =
- withB9Config cfgParser cliCfg $ \cfg ->
- run cfgParser cfg $ do
- traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory
- infoL "BUILDING ARTIFACTS"
- getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow
- assemble artifactGenerator
- return True
+buildArtifacts :: ArtifactGenerator -> B9Invokation ()
+buildArtifacts artifactGenerator = run $ do
+ traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory
+ infoL "BUILDING ARTIFACTS"
+ getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow
+ assemble artifactGenerator
+ return True
-withB9Config :: ConfigParser
- -> B9Config
- -> (B9Config -> IO Bool)
- -> IO Bool
-withB9Config cfgParser cliCfg f = do
- let parsedCfg' = parseB9Config cfgParser
- case parsedCfg' of
- Left e -> do
- putStrLn (printf "B9 Failed to start: %s" e)
- return False
- Right parsedCfg ->
- let cfg = defaultB9Config Sem.<> parsedCfg Sem.<> cliCfg
- in f cfg
diff --git a/src/lib/B9/ConfigUtils.hs b/src/lib/B9/ConfigUtils.hs
deleted file mode 100644
--- a/src/lib/B9/ConfigUtils.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-{-# Language DeriveDataTypeable #-}
-{-| Extensions to 'Data.ConfigFile' and utility functions for dealing with
- configuration in general and reading/writing files. -}
-module B9.ConfigUtils ( allOn
- , lastOn
- , SystemPath (..)
- , resolve
- , ensureDir
- , readIniFile
- , getOptionM
- , getOption
- , getOptionOr
- , IniFileException(..)
- , module Data.ConfigFile
- , UUID (..)
- , randomUUID
- , tell
- , consult
- , getDirectoryFiles
- , maybeConsult
- , maybeConsultSystemPath
- ) where
-
-import Data.Monoid
-import Data.Function ( on )
-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)
-
-allOn :: (a -> Maybe Bool) -> a -> a -> Maybe Bool
-allOn getter x y = getAll <$> on mappend (fmap All . getter) x y
-
-lastOn :: (a -> Maybe b) -> a -> a -> Maybe b
-lastOn getter x y = getLast $ on mappend (Last . getter) x y
-
-data SystemPath = Path FilePath
- | InHomeDir FilePath
- | InB9UserDir FilePath
- | InTempDir FilePath
- deriving (Eq, Read, Show, Typeable, Data)
-
-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
-
--- | 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))
-
-ensureDir :: MonadIO m => FilePath -> m ()
-ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p)
-
-data ReaderException = ReaderException FilePath String
- deriving (Show, Typeable)
-instance Exception ReaderException
-
-tell :: (MonadIO m, Show a) => FilePath -> a -> m ()
-tell f x = do
- ensureDir f
- liftIO (writeFile f (ppShow x))
-
-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
-
-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
-
-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
-
-data IniFileException = IniFileException FilePath CPError
- deriving (Show, Typeable)
-instance Exception IniFileException
-
-readIniFile :: MonadIO m => SystemPath -> m ConfigParser
-readIniFile cfgFile' = do
- cfgFile <- resolve cfgFile'
- cp' <- liftIO $ readfile emptyCP cfgFile
- case cp' of
- Left e -> liftIO $ throwIO (IniFileException cfgFile 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))
diff --git a/src/lib/B9/Content/StringTemplate.hs b/src/lib/B9/Content/StringTemplate.hs
--- a/src/lib/B9/Content/StringTemplate.hs
+++ b/src/lib/B9/Content/StringTemplate.hs
@@ -29,7 +29,7 @@
import Text.Printf
import Text.Show.Pretty (ppShow)
-import B9.ConfigUtils
+import Data.ConfigFile.B9Extras
import B9.QCUtil
-- | A wrapper around a file path and a flag indicating if template variable
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
@@ -43,7 +43,7 @@
import B9.RepositoryIO
import B9.DiskImages
import qualified B9.PartitionTable as P
-import B9.ConfigUtils
+import Data.ConfigFile.B9Extras
import B9.Content.StringTemplate
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
@@ -181,6 +181,10 @@
-- wrapper around a string that identifies a 'SharedImage'
newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)
+-- | Get the String representation of a 'SharedImageName'.
+fromSharedImageName :: SharedImageName -> String
+fromSharedImageName (SharedImageName b) = b
+
-- | The exact time that build job __started__.
-- This is a wrapper around a string contains the build date of a
-- 'SharedImage'; this is purely additional convenience and typesafety
@@ -193,6 +197,10 @@
-- around a string contains the build id of a 'SharedImage'; this is purely
-- additional convenience and typesafety
newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)
+
+-- | Get the String representation of a 'SharedImageBuildId'.
+fromSharedImageBuildId :: SharedImageBuildId -> String
+fromSharedImageBuildId (SharedImageBuildId b) = b
-- | Shared images are orderd by name, build date and build id
instance Ord SharedImage where
diff --git a/src/lib/B9/Invokation.hs b/src/lib/B9/Invokation.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/Invokation.hs
@@ -0,0 +1,124 @@
+module B9.Invokation ( B9Invokation()
+ , invokeB9
+ , invokeB9_
+ , overrideWorkingDirectory
+ , doAfterConfiguration
+ , overrideB9ConfigPath
+ , modifyInvokationConfig
+ , modifyPermanentConfig) where
+
+import B9.B9Config
+import Data.ConfigFile.B9Extras
+import Control.Monad.IO.Class
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Lens
+import Control.Exception (bracket)
+import System.Directory (getCurrentDirectory, setCurrentDirectory)
+import Data.Semigroup as Sem
+import Data.Maybe (fromMaybe)
+import Text.Printf ( printf )
+
+-- | A monad encapsulating all configuration adaptions happening before any actual
+-- build actions are performed. Use 'invokeB9' to execute these things.
+-- Inside the 'B9Invokation' monad you can influence and inspect the b9
+-- configuration, the permanent, as well as the transient.
+newtype B9Invokation a = B9Inv {runB9Invokation :: StateT InternalState IO a}
+ deriving (MonadState InternalState, Monad, Applicative, Functor, MonadIO)
+
+-- | Internal state of the 'B9Invokation'
+data InternalState = IS { _initialConfigOverride :: B9ConfigOverride
+ , _permanentB9ConfigUpdate :: Maybe (ConfigParser -> Either CPError ConfigParser)
+ , _changeWorkingDirectory :: Maybe FilePath
+ , _buildAction :: ReaderT B9Config IO Bool
+ }
+
+makeLenses ''InternalState
+
+initialState :: InternalState
+initialState =
+ IS (B9ConfigOverride Nothing mempty) Nothing Nothing (return True)
+
+-- | Run a 'B9Invokation'.
+-- If the user has no B9 config file yet, a default config file will be created.
+invokeB9 :: B9Invokation a -> IO (a, Bool)
+invokeB9 act = do
+ (a, st) <- runStateT (runB9Invokation act) initialState
+ let cfgPath = st ^. initialConfigOverride . customB9ConfigPath
+ cp0 <- openOrCreateB9Config cfgPath
+ let cpExtErr = fmap ($ cp0) (st ^. permanentB9ConfigUpdate)
+ cpExt <- maybe
+ (return Nothing)
+ ( either
+ ( fail
+ . printf "Internal configuration error! Please report this: %s\n"
+ . show
+ )
+ (return . Just)
+ )
+ cpExtErr
+ let cp = fromMaybe cp0 cpExt
+ mapM_ (writeB9ConfigParser cfgPath) cpExt
+ case parseB9Config cp of
+ Left e -> fail (printf "Configuration error: %s\n" (show e))
+ Right permanentConfig -> do
+ let runtimeCfg =
+ permanentConfig
+ Sem.<> st
+ ^. initialConfigOverride
+ . customB9Config
+ completeBuildAction = bracket
+ getCurrentDirectory
+ setCurrentDirectory
+ ( const
+ ( do
+ mapM_ setCurrentDirectory
+ (st ^. changeWorkingDirectory)
+ runReaderT (st ^. buildAction) runtimeCfg
+ )
+ )
+ res <- completeBuildAction
+ return (a, res)
+
+-- | Run a 'B9Invokation' and ignore the results of the invokation monad and
+-- instead return the results of the '_buildAction'.
+-- See: 'invokeB9'
+invokeB9_ :: B9Invokation a -> IO Bool
+invokeB9_ act = snd <$> invokeB9 act
+
+-- | Add an action to be executed once the configuration has been done.
+doAfterConfiguration :: ReaderT B9Config IO Bool -> B9Invokation ()
+doAfterConfiguration action = buildAction %= (>> action)
+
+-- | Override the B9 configuration path
+overrideB9ConfigPath :: SystemPath -> B9Invokation ()
+overrideB9ConfigPath p = initialConfigOverride . customB9ConfigPath .= Just p
+
+-- | Override the current working directory during execution of the actions
+-- added with 'doAfterConfiguration'.
+overrideWorkingDirectory :: FilePath -> B9Invokation ()
+overrideWorkingDirectory p = changeWorkingDirectory .= Just p
+
+-- | Modify the current 'B9Config'. The modifications are not reflected in the
+-- config file or the 'ConfigParser' returned by 'askInvokationConfigParser'.
+modifyInvokationConfig :: (B9Config -> B9Config) -> B9Invokation ()
+modifyInvokationConfig f = initialConfigOverride . customB9Config %= f
+
+-- | Modify the current 'B9Config'. The modifications are not reflected in the
+-- config file or the 'ConfigParser' returned by 'askInvokationConfigParser'.
+modifyPermanentConfig :: (B9Config -> B9Config) -> B9Invokation ()
+modifyPermanentConfig g = permanentB9ConfigUpdate %= go
+ where
+ go Nothing = go (Just return)
+ go (Just f) = Just (\cp -> f cp >>= modifyConfigParser g)
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs
--- a/src/lib/B9/LibVirtLXC.hs
+++ b/src/lib/B9/LibVirtLXC.hs
@@ -1,7 +1,8 @@
{-| Implementation of an execution environment that uses "libvirt-lxc". -}
module B9.LibVirtLXC ( runInEnvironment
, supportedImageTypes
- , setDefaultConfig
+ , logLibVirtLXCConfig
+ , module X
) where
import Control.Monad.IO.Class ( liftIO )
@@ -9,297 +10,210 @@
import System.FilePath
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.ConfigUtils
+import B9.B9Config.LibVirtLXC as X
+import Data.ConfigFile.B9Extras
+
+logLibVirtLXCConfig :: LibVirtLXCConfig -> B9 ()
+logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)
+
supportedImageTypes :: [ImageType]
supportedImageTypes = [Raw]
runInEnvironment :: ExecEnv -> Script -> B9 Bool
-runInEnvironment env scriptIn =
- if emptyScript scriptIn
- then return True
- else setUp >>= execute
- where
- setUp = do
- cfg <- configureLibVirtLXC
- buildId <- getBuildId
- buildBaseDir <- getBuildDir
- uuid <- randomUUID
- let scriptDirHost = buildDir "init-script"
- scriptDirGuest = "/" ++ buildId
- domainFile = buildBaseDir uuid' <.> domainConfig
- domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest
- uuid' = printf "%U" uuid
- setupEnv = Begin [ Run "export" ["HOME=/root"]
- , Run "export" ["USER=root"]
- , Run "source" ["/etc/profile"]]
- script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]
- buildDir = buildBaseDir uuid'
- liftIO $ do
- createDirectoryIfMissing True scriptDirHost
- writeSh (scriptDirHost initScript) script
- writeFile domainFile domain
- return $ Context scriptDirHost uuid domainFile cfg
+runInEnvironment env scriptIn = if emptyScript scriptIn
+ then return True
+ else setUp >>= execute
+ where
+ setUp = do
+ mcfg <- view libVirtLXCConfigs <$> getConfig
+ cfg <- maybe (fail "No LibVirtLXC Configuration!") return mcfg
+ buildId <- getBuildId
+ buildBaseDir <- getBuildDir
+ uuid <- randomUUID
+ let
+ scriptDirHost = buildDir "init-script"
+ scriptDirGuest = "/" ++ buildId
+ domainFile = buildBaseDir uuid' <.> domainConfig
+ domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest
+ uuid' = printf "%U" uuid
+ setupEnv = Begin
+ [ Run "export" ["HOME=/root"]
+ , Run "export" ["USER=root"]
+ , Run "source" ["/etc/profile"]
+ ]
+ script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]
+ buildDir = buildBaseDir uuid'
+ liftIO $ do
+ createDirectoryIfMissing True scriptDirHost
+ writeSh (scriptDirHost initScript) script
+ writeFile domainFile domain
+ return $ Context scriptDirHost uuid domainFile cfg
- successMarkerCmd scriptDirGuest =
- In scriptDirGuest [Run "touch" [successMarkerFile]]
+ successMarkerCmd scriptDirGuest =
+ In scriptDirGuest [Run "touch" [successMarkerFile]]
- execute (Context scriptDirHost _uuid domainFile cfg) = do
- let virsh = virshCommand cfg
- cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile
- -- cmd $ printf "%s console %U" virsh uuid
- liftIO (doesFileExist $ scriptDirHost successMarkerFile)
+ execute (Context scriptDirHost _uuid domainFile cfg) = do
+ let virsh = virshCommand cfg
+ cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile
+ -- cmd $ printf "%s console %U" virsh uuid
+ liftIO (doesFileExist $ scriptDirHost successMarkerFile)
- successMarkerFile = "SUCCESS"
+ successMarkerFile = "SUCCESS"
- virshCommand :: LibVirtLXCConfig -> String
- virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'
- where
- useSudo' = if useSudo cfg
- then "sudo "
- else ""
- virshPath' = virshPath cfg
- virshURI' = virshURI cfg
+ virshCommand :: LibVirtLXCConfig -> String
+ virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'
+ where
+ useSudo' = if useSudo cfg then "sudo " else ""
+ virshPath' = virshPath cfg
+ virshURI' = virshURI cfg
data Context = Context FilePath UUID FilePath LibVirtLXCConfig
-data LibVirtLXCConfig = LibVirtLXCConfig { useSudo :: Bool
- , virshPath :: FilePath
- , emulator :: FilePath
- , virshURI :: FilePath
- , networkId :: Maybe String
- , guestCapabilities :: [LXCGuestCapability]
- , guestRamSize :: RamSize
- } deriving (Read, Show)
--- | Available linux capabilities for lxc containers. This maps directly to the
--- capabilities defined in 'man 7 capabilities'.
-data LXCGuestCapability = CAP_MKNOD
- | CAP_AUDIT_CONTROL
- | CAP_AUDIT_READ
- | CAP_AUDIT_WRITE
- | CAP_BLOCK_SUSPEND
- | CAP_CHOWN
- | CAP_DAC_OVERRIDE
- | CAP_DAC_READ_SEARCH
- | CAP_FOWNER
- | CAP_FSETID
- | CAP_IPC_LOCK
- | CAP_IPC_OWNER
- | CAP_KILL
- | CAP_LEASE
- | CAP_LINUX_IMMUTABLE
- | CAP_MAC_ADMIN
- | CAP_MAC_OVERRIDE
- | CAP_NET_ADMIN
- | CAP_NET_BIND_SERVICE
- | CAP_NET_BROADCAST
- | CAP_NET_RAW
- | CAP_SETGID
- | CAP_SETFCAP
- | CAP_SETPCAP
- | CAP_SETUID
- | CAP_SYS_ADMIN
- | CAP_SYS_BOOT
- | CAP_SYS_CHROOT
- | CAP_SYS_MODULE
- | CAP_SYS_NICE
- | CAP_SYS_PACCT
- | CAP_SYS_PTRACE
- | CAP_SYS_RAWIO
- | CAP_SYS_RESOURCE
- | CAP_SYS_TIME
- | CAP_SYS_TTY_CONFIG
- | CAP_SYSLOG
- | CAP_WAKE_ALARM
- deriving (Read, Show)
-
-defaultLibVirtLXCConfig :: LibVirtLXCConfig
-defaultLibVirtLXCConfig = LibVirtLXCConfig
- True
- "/usr/bin/virsh"
- "/usr/lib/libvirt/libvirt_lxc"
- "lxc:///"
- Nothing
- [ CAP_MKNOD
- , CAP_SYS_ADMIN
- , CAP_SYS_CHROOT
- , CAP_SETGID
- , CAP_SETUID
- , CAP_NET_BIND_SERVICE
- , CAP_SETPCAP
- , CAP_SYS_PTRACE
- , CAP_SYS_MODULE
- ]
- (RamSize 1 GB)
-
-cfgFileSection :: String
-cfgFileSection = "libvirt-lxc"
-useSudoK :: String
-useSudoK = "use_sudo"
-virshPathK :: String
-virshPathK = "virsh_path"
-emulatorK :: String
-emulatorK = "emulator_path"
-virshURIK :: String
-virshURIK = "connection"
-networkIdK :: String
-networkIdK = "network"
-guestCapabilitiesK :: String
-guestCapabilitiesK = "guest_capabilities"
-guestRamSizeK :: String
-guestRamSizeK = "guest_ram_size"
-
-configureLibVirtLXC :: B9 LibVirtLXCConfig
-configureLibVirtLXC = do
- c <- readLibVirtConfig
- traceL $ printf "USING LibVirtLXCConfig: %s" (show c)
- return c
-
-setDefaultConfig :: ConfigParser
-setDefaultConfig = either (error . show) id eitherCp
- where
- eitherCp = do
- let cp = emptyCP
- c = defaultLibVirtLXCConfig
- 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
-
-readLibVirtConfig :: B9 LibVirtLXCConfig
-readLibVirtConfig =
- do
- cp <- getConfigParser
- let geto :: (Get_C a)
- => OptionSpec -> a -> a
- geto = getOptionOr cp cfgFileSection
- return
- LibVirtLXCConfig { useSudo = geto useSudoK $
- useSudo defaultLibVirtLXCConfig
- , virshPath = geto virshPathK $
- virshPath defaultLibVirtLXCConfig
- , emulator = geto emulatorK $
- emulator defaultLibVirtLXCConfig
- , virshURI = geto virshURIK $
- virshURI defaultLibVirtLXCConfig
- , networkId = geto networkIdK $
- networkId defaultLibVirtLXCConfig
- , guestCapabilities = geto guestCapabilitiesK $
- guestCapabilities defaultLibVirtLXCConfig
- , guestRamSize = geto guestRamSizeK $
- guestRamSize defaultLibVirtLXCConfig
- }
-
initScript :: String
initScript = "init.sh"
domainConfig :: String
domainConfig = "domain.xml"
-createDomain :: LibVirtLXCConfig
- -> ExecEnv
- -> String
- -> String
- -> FilePath
- -> FilePath
- -> String
+createDomain
+ :: LibVirtLXCConfig
+ -> ExecEnv
+ -> String
+ -> String
+ -> FilePath
+ -> FilePath
+ -> String
createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =
- "\n " ++ buildId ++ "\n " ++ uuid ++ "\n " ++ memoryAmount cfg e ++ "\n " ++ memoryAmount cfg e ++ "\n " ++ cpuCountStr e ++ "\n \n \n "++ renderGuestCapabilityEntries cfg ++"\n \n \n \n exe\n " ++ scriptDirGuest initScript ++ "\n \n \n destroy\n restart\n destroy\n \n " ++ emulator cfg ++ "\n"
- ++ unlines (libVirtNetwork (networkId cfg) ++
- (fsImage <$> envImageMounts e) ++
- (fsSharedDir <$> envSharedDirectories e)) ++ "\n" ++
- " \n \n \n \n \n \n \n \n\n"
+ "\n "
+ ++ buildId
+ ++ "\n "
+ ++ uuid
+ ++ "\n "
+ ++ memoryAmount cfg e
+ ++ "\n "
+ ++ memoryAmount cfg e
+ ++ "\n "
+ ++ cpuCountStr e
+ ++ "\n \n \n "
+ ++ renderGuestCapabilityEntries cfg
+ ++ "\n \n \n \n exe\n "
+ ++ scriptDirGuest
+ initScript
+ ++ "\n \n \n destroy\n restart\n destroy\n \n "
+ ++ emulator cfg
+ ++ "\n"
+ ++ unlines
+ ( libVirtNetwork (networkId cfg)
+ ++ (fsImage <$> envImageMounts e)
+ ++ (fsSharedDir <$> envSharedDirectories e)
+ )
+ ++ "\n"
+ ++ " \n \n \n \n \n \n \n \n\n"
renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
renderGuestCapabilityEntries = unlines . map render . guestCapabilities
- where
- render :: LXCGuestCapability -> String
- render cap =
- let capStr = toLower <$> drop (length "CAP_") (show cap)
- in printf "<%s state='on'/>" capStr
+ where
+ render :: LXCGuestCapability -> String
+ render cap =
+ let capStr = toLower <$> drop (length "CAP_") (show cap)
+ in printf "<%s state='on'/>" capStr
osArch :: ExecEnv -> String
osArch e = case cpuArch (envResources e) of
- X86_64 -> "x86_64"
- I386 -> "i686"
+ X86_64 -> "x86_64"
+ I386 -> "i686"
libVirtNetwork :: Maybe String -> [String]
libVirtNetwork Nothing = []
libVirtNetwork (Just n) =
[ ""
, " "
- , "" ]
+ , ""
+ ]
fsImage :: (Image, MountPoint) -> String
-fsImage (img, mnt) =
- case fsTarget mnt of
- Just mntXml ->
- "\n " ++
- fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++
- "\n"
- Nothing ->
- ""
- where
- fsImgDriver (Image _img fmt _fs) =
- printf "" driver fmt'
- where
- (driver, fmt') =
- case fmt of
- Raw -> ("type='loop'", "format='raw'")
- QCow2 -> ("type='nbd'", "format='qcow2'")
- Vmdk -> ("type='nbd'", "format='vmdk'")
+fsImage (img, mnt) = case fsTarget mnt of
+ Just mntXml ->
+ "\n "
+ ++ fsImgDriver img
+ ++ "\n "
+ ++ fsImgSource img
+ ++ "\n "
+ ++ mntXml
+ ++ "\n"
+ Nothing -> ""
+ where
+ fsImgDriver (Image _img fmt _fs) = printf "" driver fmt'
+ where
+ (driver, fmt') = case fmt of
+ Raw -> ("type='loop'", "format='raw'")
+ QCow2 -> ("type='nbd'", "format='qcow2'")
+ Vmdk -> ("type='nbd'", "format='vmdk'")
- fsImgSource (Image src _fmt _fs) = ""
+ fsImgSource (Image src _fmt _fs) = ""
fsSharedDir :: SharedDirectory -> String
-fsSharedDir (SharedDirectory hostDir mnt) =
- case fsTarget mnt of
- Just mntXml ->
- "\n " ++
- "" ++ "\n " ++ mntXml ++
- "\n"
- Nothing ->
- ""
-fsSharedDir (SharedDirectoryRO hostDir mnt) =
- case fsTarget mnt of
- Just mntXml ->
- "\n " ++
- "" ++ "\n " ++ mntXml ++
- "\n \n"
- Nothing ->
- ""
-fsSharedDir (SharedSources _) =
- error "Unreachable code reached!"
+fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of
+ Just mntXml ->
+ "\n "
+ ++ ""
+ ++ "\n "
+ ++ mntXml
+ ++ "\n"
+ Nothing -> ""
+fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of
+ Just mntXml ->
+ "\n "
+ ++ ""
+ ++ "\n "
+ ++ mntXml
+ ++ "\n \n"
+ Nothing -> ""
+fsSharedDir (SharedSources _) = error "Unreachable code reached!"
fsTarget :: MountPoint -> Maybe String
fsTarget (MountPoint dir) = Just $ ""
-fsTarget _ = Nothing
+fsTarget _ = Nothing
memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String
memoryUnit cfg = toUnit . maxMemory . envResources
- where
- toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
- toUnit (RamSize _ u) =
- case u of
- GB -> "GiB"
- MB -> "MiB"
- KB -> "KiB"
- B -> "B"
+ where
+ toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
+ toUnit (RamSize _ u) = case u of
+ GB -> "GiB"
+ MB -> "MiB"
+ KB -> "KiB"
+ B -> "B"
memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String
memoryAmount cfg = show . toAmount . maxMemory . envResources
- where
- toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
- toAmount (RamSize n _) = n
+ where
+ toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
+ toAmount (RamSize n _) = n
cpuCountStr :: ExecEnv -> String
cpuCountStr = show . cpuCount . envResources
+
+
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
@@ -3,56 +3,25 @@
the whole thing is supposed to be build-server-safe, that means no two builds
shall interfere with each other. This is accomplished by refraining from
automatic cache updates from/to remote repositories.-}
-module B9.Repository (RemoteRepo(..)
- ,remoteRepoRepoId
- ,RepoCache(..)
- ,SshPrivKey(..)
- ,SshRemoteHost(..)
- ,SshRemoteUser(..)
- ,initRepoCache
+module B9.Repository (initRepoCache
,initRemoteRepo
,cleanRemoteRepo
,remoteRepoCheckSshPrivKey
,remoteRepoCacheDir
,localRepoDir
- ,writeRemoteRepoConfig
- ,getConfiguredRemoteRepos
- ,lookupRemoteRepo) where
+ ,lookupRemoteRepo
+ ,module X) where
import Control.Monad
import Control.Monad.IO.Class
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
-import Data.Data
-import Data.List
-import Data.ConfigFile
import Text.Printf
import System.FilePath
import System.Directory
-import B9.ConfigUtils
-
-newtype RepoCache = RepoCache FilePath
- deriving (Read, Show, Typeable, Data)
-
-data RemoteRepo = RemoteRepo String
- FilePath
- SshPrivKey
- SshRemoteHost
- SshRemoteUser
- deriving (Read, Show, Typeable, Data)
-
-remoteRepoRepoId :: RemoteRepo -> String
-remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId
-
-newtype SshPrivKey = SshPrivKey FilePath
- deriving (Read, Show, Typeable, Data)
-
-newtype SshRemoteHost = SshRemoteHost (String,Int)
- deriving (Read, Show, Typeable, Data)
-
-newtype SshRemoteUser = SshRemoteUser String
- deriving (Read, Show, Typeable, Data)
+import B9.B9Config.Repository as X
+import Data.ConfigFile.B9Extras
-- | Initialize the local repository cache directory.
initRepoCache :: MonadIO m => SystemPath -> m RepoCache
@@ -118,64 +87,8 @@
localRepoDir (RepoCache cacheDir) =
cacheDir "local-repo"
--- | Persist a repo to a configuration file.
-writeRemoteRepoConfig :: RemoteRepo
- -> ConfigParser
- -> Either CPError ConfigParser
-writeRemoteRepoConfig 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
-
--- | Load a repository from a configuration file that has been written by
--- 'writeRepositoryToB9Config'.
+-- | Select the first 'RemoteRepo' with a given @repoId@.
lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo
lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs
where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid,r)) repos
-getConfiguredRemoteRepos :: ConfigParser -> [RemoteRepo]
-getConfiguredRemoteRepos cp = map parseRepoSection repoSections
- where
- repoSections =
- filter (repoSectionSuffix `isSuffixOf`) (sections cp)
- parseRepoSection section =
- case parseResult of
- Left e -> error ("Error while parsing repo section \""
- ++ section ++ "\": " ++ show e)
- Right r -> r
- 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
-
-repoSectionSuffix :: String
-repoSectionSuffix = "-repo"
-repoRemotePathK :: String
-repoRemotePathK = "remote_path"
-repoRemoteSshKeyK :: String
-repoRemoteSshKeyK = "ssh_priv_key_file"
-repoRemoteSshHostK :: String
-repoRemoteSshHostK = "ssh_remote_host"
-repoRemoteSshPortK :: String
-repoRemoteSshPortK = "ssh_remote_port"
-repoRemoteSshUserK :: String
-repoRemoteSshUserK = "ssh_remote_user"
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
@@ -10,7 +10,7 @@
import B9.Repository
import B9.B9Monad
-import B9.ConfigUtils
+import Data.ConfigFile.B9Extras
import Data.List
diff --git a/src/lib/B9/Shake.hs b/src/lib/B9/Shake.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/Shake.hs
@@ -0,0 +1,6 @@
+-- | A module that re-exports all B9 Shake integration.
+-- Which by the way is crude and preliminary...
+module B9.Shake (module X) where
+
+import B9.Shake.Actions as X
+import B9.Shake.SharedImageRules as X
diff --git a/src/lib/B9/Shake/Actions.hs b/src/lib/B9/Shake/Actions.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/Shake/Actions.hs
@@ -0,0 +1,23 @@
+-- | Convenient Shake 'Action's for 'B9' rules.
+module B9.Shake.Actions (b9InvokationAction, buildB9File) where
+
+import Development.Shake
+import Development.Shake.FilePath
+import B9
+
+-- | Convert a 'B9Invokation' action into a Shake 'Action'.
+b9InvokationAction :: B9Invokation a -> Action (a, Bool)
+b9InvokationAction = liftIO . runB9 . defaultB9RunParameters
+
+-- | An action that does the equivalent of
+-- @b9c build -f -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@
+-- with the current working directory changed to @b9Root@.
+buildB9File :: FilePath -> FilePath -> [String] -> Action ()
+buildB9File b9Root b9File args = do
+ let f = b9Root b9File
+ need [f]
+ (_, success) <- b9InvokationAction $ do
+ modifyInvokationConfig (appendPositionalArguments args)
+ overrideWorkingDirectory b9Root
+ runBuildArtifacts [f]
+ if success then return () else fail $ "ERROR: Build failed: " ++ f
diff --git a/src/lib/B9/Shake/SharedImageRules.hs b/src/lib/B9/Shake/SharedImageRules.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/Shake/SharedImageRules.hs
@@ -0,0 +1,120 @@
+-- | A crude, unsafe and preliminary solution to building B9 'SharedImage's
+-- from Shake.
+module B9.Shake.SharedImageRules ( customSharedImageAction
+ , needSharedImage
+ , enableSharedImageRules) where
+
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.Rule
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as LazyByteString
+import qualified Data.Binary as Binary
+import B9
+import B9.Shake.Actions (b9InvokationAction)
+
+-- | In order to use 'needSharedImage' and 'customSharedImageAction' you need to
+-- call this action before using any of the afore mentioned.
+enableSharedImageRules :: Rules ()
+enableSharedImageRules = addBuiltinRule noLint go
+ where
+ go :: SharedImageName
+ -> Maybe ByteString.ByteString
+ -> Bool
+ -> Action (RunResult SharedImageBuildId)
+ go nameQ mSerlializedBuildId dependenciesChanged = do
+ (mCurrentBuildId, success) <- b9InvokationAction (runLookupLocalSharedImage nameQ)
+ unless success
+ (internalErrorSharedImageNotFound nameQ)
+
+ case (decodeBuildId <$> mSerlializedBuildId, mCurrentBuildId) of
+
+ (Nothing, Nothing) ->
+ do newBuildId <- rebuild
+ return (RunResult ChangedRecomputeDiff (encodeBuildId newBuildId) newBuildId)
+
+ (Nothing, Just currentBuildId) ->
+ if dependenciesChanged then
+ do newBuildId <- rebuild
+ let changed = if newBuildId == currentBuildId
+ then ChangedStore
+ else ChangedRecomputeDiff
+ return (RunResult changed (encodeBuildId newBuildId) newBuildId)
+ else
+ return (RunResult ChangedStore (encodeBuildId currentBuildId) currentBuildId)
+
+ (Just oldBuildId, Nothing) ->
+ do newBuildId <- rebuild
+ let changed = if oldBuildId == newBuildId
+ then ChangedRecomputeSame
+ else ChangedRecomputeDiff
+ return (RunResult changed (encodeBuildId newBuildId) newBuildId)
+
+ (Just oldBuildId, Just currentBuildId) ->
+ do newBuildId <- if dependenciesChanged
+ then rebuild
+ else return currentBuildId
+ let changed = if oldBuildId == newBuildId
+ then if dependenciesChanged
+ then ChangedRecomputeSame
+ else ChangedNothing
+ else ChangedRecomputeDiff
+
+ return (RunResult changed (encodeBuildId newBuildId) newBuildId)
+
+ where
+ decodeBuildId :: ByteString.ByteString -> SharedImageBuildId
+ decodeBuildId = Binary.decode . LazyByteString.fromStrict
+
+ encodeBuildId :: SharedImageBuildId -> ByteString.ByteString
+ encodeBuildId = LazyByteString.toStrict . Binary.encode
+
+ rebuild :: Action SharedImageBuildId
+ rebuild = do
+ rules <- getUserRules
+ case userRuleMatch rules imgMatch of
+ [] -> fail $ "No rules to build B9 shared image " ++ show nameQ ++ " found"
+ [act] -> act
+ _rs -> fail $ "Multiple rules for the B9 shared image " ++ show nameQ ++ " found"
+ where
+ imgMatch (SharedImageCustomActionRule name mkImage) =
+ if name == nameQ then Just mkImage else Nothing
+
+-- | Add a dependency to the creation of a 'SharedImage'. The build action
+-- for the shared image must have been supplied by e.g. 'customSharedImageAction'.
+-- NOTE: You must call 'enableSharedImageRules' before this action works.
+needSharedImage :: SharedImageName -> Action SharedImageBuildId
+needSharedImage = apply1
+
+-- | Specify an arbitrary action that is supposed to build the given shared
+-- image identified by a 'SharedImageName'.
+-- NOTE: You must call 'enableSharedImageRules' before this action works.
+customSharedImageAction :: SharedImageName -> Action () -> Rules ()
+customSharedImageAction b9img customAction =
+ addUserRule $ SharedImageCustomActionRule b9img $ do
+ customAction
+ (after, success) <- b9InvokationAction (runLookupLocalSharedImage b9img)
+ unless success
+ (internalErrorSharedImageNotFound b9img)
+ maybe
+ (errorSharedImageNotFound b9img)
+ return
+ after
+
+type instance RuleResult SharedImageName = SharedImageBuildId
+
+data SharedImageCustomActionRule =
+ SharedImageCustomActionRule SharedImageName (Action SharedImageBuildId)
+ deriving Typeable
+
+internalErrorSharedImageNotFound :: Monad m => SharedImageName -> m a
+internalErrorSharedImageNotFound =
+ fail
+ . printf "Internal Error: SharedImage %s not found. Please report this."
+ . show
+
+errorSharedImageNotFound :: Monad m => SharedImageName -> m a
+errorSharedImageNotFound =
+ fail
+ . printf "Error: SharedImage %s not found."
+ . show
diff --git a/src/lib/Data/ConfigFile/B9Extras.hs b/src/lib/Data/ConfigFile/B9Extras.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/Data/ConfigFile/B9Extras.hs
@@ -0,0 +1,151 @@
+{-# Language DeriveDataTypeable #-}
+{-| 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
+ ) where
+
+import Data.Monoid
+import Data.Function ( on )
+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)
+
+allOn :: (a -> Maybe Bool) -> a -> a -> Maybe Bool
+allOn getter x y = getAll <$> on mappend (fmap All . getter) x y
+
+lastOn :: (a -> Maybe b) -> a -> a -> Maybe b
+lastOn getter x y = getLast $ on mappend (Last . getter) x y
+
+data SystemPath = Path FilePath
+ | InHomeDir FilePath
+ | InB9UserDir FilePath
+ | InTempDir FilePath
+ deriving (Eq, Read, Show, Typeable, Data)
+
+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
+
+-- | 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))
+
+ensureDir :: MonadIO m => FilePath -> m ()
+ensureDir p = liftIO (createDirectoryIfMissing True $ takeDirectory p)
+
+data ReaderException = ReaderException FilePath String
+ deriving (Show, Typeable)
+instance Exception ReaderException
+
+tell :: (MonadIO m, Show a) => FilePath -> a -> m ()
+tell f x = do
+ ensureDir f
+ liftIO (writeFile f (ppShow x))
+
+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
+
+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
+
+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
+
+data IniFileException = IniFileException FilePath CPError
+ deriving (Show, Typeable)
+instance Exception IniFileException
+
+readIniFile :: MonadIO m => SystemPath -> m ConfigParser
+readIniFile cfgFile' = do
+ cfgFilePath <- resolve cfgFile'
+ liftIO $ do
+ res <- readfile emptyCP cfgFilePath
+ case res of
+ Left e -> throwIO (IniFileException 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))