b9 0.5.41 → 0.5.42

raw patch · 22 files changed

+1597/−1202 lines, 22 filesdep +lensdep +shakePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lens, shake

API changes (from Hackage documentation)

Files

• README.md +7/−23
• b9.cabal +27/−18
• src/cli/Main.hs +216/−381
• src/lib/B9.hs +209/−14
• src/lib/B9/ArtifactGeneratorImpl.hs +3/−4
• src/lib/B9/B9Config.hs +176/−106
• src/lib/B9/B9Config/LibVirtLXC.hs +128/−0
• src/lib/B9/B9Config/Repository.hs +90/−0
• src/lib/B9/B9Monad.hs +135/−144
• src/lib/B9/Builder.hs +9/−24
• src/lib/B9/ConfigUtils.hs +0/−150
• src/lib/B9/Content/StringTemplate.hs +1/−1
• src/lib/B9/DiskImageBuilder.hs +1/−1
• src/lib/B9/DiskImages.hs +8/−0
• src/lib/B9/Invokation.hs +124/−0
• src/lib/B9/LibVirtLXC.hs +156/−242
• src/lib/B9/Repository.hs +6/−93
• src/lib/B9/RepositoryIO.hs +1/−1
• src/lib/B9/Shake.hs +6/−0
• src/lib/B9/Shake/Actions.hs +23/−0
• src/lib/B9/Shake/SharedImageRules.hs +120/−0
• src/lib/Data/ConfigFile/B9Extras.hs +151/−0

@@ -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

@@ -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

@@ -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

@@ -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'+

@@ -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

@@ -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

@@ -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)++++

@@ -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"

@@ -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++++

@@ -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

@@ -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))

@@ -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

@@ -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  

@@ -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

@@ -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)+++++++++++

@@ -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 =-  "<domain type='lxc'>\n  <name>" ++ buildId ++ "</name>\n  <uuid>" ++ uuid ++ "</uuid>\n  <memory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</memory>\n  <currentMemory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</currentMemory>\n  <vcpu placement='static'>" ++ cpuCountStr e ++ "</vcpu>\n  <features>\n   <capabilities policy='default'>\n     "++ renderGuestCapabilityEntries cfg  ++"\n   </capabilities>\n  </features>\n  <os>\n    <type arch='" ++ osArch e ++ "'>exe</type>\n    <init>" ++ scriptDirGuest </> initScript ++ "</init>\n  </os>\n  <clock offset='utc'/>\n  <on_poweroff>destroy</on_poweroff>\n  <on_reboot>restart</on_reboot>\n  <on_crash>destroy</on_crash>\n  <devices>\n    <emulator>" ++ emulator cfg ++ "</emulator>\n"-  ++ unlines (libVirtNetwork (networkId cfg) ++-              (fsImage <$> envImageMounts e) ++-              (fsSharedDir <$> envSharedDirectories e)) ++ "\n" ++-  "    <filesystem type='mount'>\n      <source dir='" ++ scriptDirHost ++ "'/>\n      <target dir='" ++ scriptDirGuest ++ "'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\n"+  "<domain type='lxc'>\n  <name>"+    ++  buildId+    ++  "</name>\n  <uuid>"+    ++  uuid+    ++  "</uuid>\n  <memory unit='"+    ++  memoryUnit cfg e+    ++  "'>"+    ++  memoryAmount cfg e+    ++  "</memory>\n  <currentMemory unit='"+    ++  memoryUnit cfg e+    ++  "'>"+    ++  memoryAmount cfg e+    ++  "</currentMemory>\n  <vcpu placement='static'>"+    ++  cpuCountStr e+    ++  "</vcpu>\n  <features>\n   <capabilities policy='default'>\n     "+    ++  renderGuestCapabilityEntries cfg+    ++  "\n   </capabilities>\n  </features>\n  <os>\n    <type arch='"+    ++  osArch e+    ++  "'>exe</type>\n    <init>"+    ++  scriptDirGuest+    </> initScript+    ++ "</init>\n  </os>\n  <clock offset='utc'/>\n  <on_poweroff>destroy</on_poweroff>\n  <on_reboot>restart</on_reboot>\n  <on_crash>destroy</on_crash>\n  <devices>\n    <emulator>"+    ++  emulator cfg+    ++  "</emulator>\n"+    ++  unlines+          (  libVirtNetwork (networkId cfg)+          ++ (fsImage <$> envImageMounts e)+          ++ (fsSharedDir <$> envSharedDirectories e)+          )+    ++  "\n"+    ++  "    <filesystem type='mount'>\n      <source dir='"+    ++  scriptDirHost+    ++  "'/>\n      <target dir='"+    ++  scriptDirGuest+    ++ "'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\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) =   [ "<interface type='network'>"   , "  <source network='" ++ n ++ "'/>"-  , "</interface>" ]+  , "</interface>"+  ]  fsImage :: (Image, MountPoint) -> String-fsImage (img, mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='file' accessmode='passthrough'>\n  " ++-      fsImgDriver img ++ "\n  " ++ fsImgSource img ++ "\n  " ++ mntXml ++-                                                                "\n</filesystem>"-    Nothing ->-      ""-  where-    fsImgDriver (Image _img fmt _fs) =-      printf "<driver %s %s/>" 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 ->+    "<filesystem type='file' accessmode='passthrough'>\n  "+      ++ fsImgDriver img+      ++ "\n  "+      ++ fsImgSource img+      ++ "\n  "+      ++ mntXml+      ++ "\n</filesystem>"+  Nothing -> ""+ where+  fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" 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) = "<source file='" ++ src ++ "'/>"+  fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"  fsSharedDir :: SharedDirectory -> String-fsSharedDir (SharedDirectory hostDir mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='mount'>\n  " ++-      "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++-      "\n</filesystem>"-    Nothing ->-      ""-fsSharedDir (SharedDirectoryRO hostDir mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='mount'>\n  " ++-      "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++-      "\n  <readonly />\n</filesystem>"-    Nothing ->-      ""-fsSharedDir (SharedSources _) =-  error "Unreachable code reached!"+fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of+  Just mntXml ->+    "<filesystem type='mount'>\n  "+      ++ "<source dir='"+      ++ hostDir+      ++ "'/>"+      ++ "\n  "+      ++ mntXml+      ++ "\n</filesystem>"+  Nothing -> ""+fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of+  Just mntXml ->+    "<filesystem type='mount'>\n  "+      ++ "<source dir='"+      ++ hostDir+      ++ "'/>"+      ++ "\n  "+      ++ mntXml+      ++ "\n  <readonly />\n</filesystem>"+  Nothing -> ""+fsSharedDir (SharedSources _) = error "Unreachable code reached!"  fsTarget :: MountPoint -> Maybe String fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"-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++

@@ -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"

@@ -10,7 +10,7 @@  import B9.Repository import B9.B9Monad-import B9.ConfigUtils+import Data.ConfigFile.B9Extras   import Data.List

@@ -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

@@ -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 <b9file> -- (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

@@ -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

@@ -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))