b9 0.5.43 → 0.5.44

raw patch · 12 files changed

+406/−425 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• b9.cabal +1/−3
• src/cli/Main.hs +58/−38
• src/lib/B9.hs +136/−94
• src/lib/B9/ArtifactGeneratorImpl.hs +10/−1
• src/lib/B9/B9Config.hs +135/−13
• src/lib/B9/B9Monad.hs +43/−51
• src/lib/B9/Builder.hs +0/−41
• src/lib/B9/Content/YamlObject.hs +4/−5
• src/lib/B9/Invokation.hs +0/−161
• src/lib/B9/Shake/Actions.hs +10/−9
• src/lib/B9/Shake/SharedImageRules.hs +7/−8
• stack.yaml +2/−1

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.43+version:             0.5.44  synopsis:            A tool and library for building virtual machine images. @@ -75,7 +75,6 @@                    , B9.B9Config.LibVirtLXC                    , B9.B9Config.Repository                    , B9.B9Monad-                   , B9.Builder                    , B9.Content.AST                    , B9.Content.ErlangPropList                    , B9.Content.ErlTerms@@ -86,7 +85,6 @@                    , B9.DiskImages                    , B9.DSL                    , B9.ExecEnv-                   , B9.Invokation                    , B9.LibVirtLXC                    , B9.MBR                    , B9.PartitionTable

@@ -7,27 +7,34 @@  main :: IO () main = do-    b9Opts <- parseCommandLine-    result <- invokeB9 (applyB9RunParameters b9Opts)-    exit (maybe False (const True) result)-    where exit success = when (not success) (exitWith (ExitFailure 128))+    b9Opts  <- parseCommandLine+    applyB9RunParameters b9Opts + -- | A data structure that contains the `B9Invokation` -- as well as build parameters.-data B9RunParameters a =+data B9RunParameters =   B9RunParameters             B9ConfigOverride-            (B9Invokation a ())+            Cmd             BuildVariables -applyB9RunParameters :: B9RunParameters a -> B9Invokation a ()-applyB9RunParameters (B9RunParameters overrides action vars) = do-    modifyInvokationConfig-      (over envVars (++ vars) . const (overrides ^. customB9Config))-    mapM_ overrideB9ConfigPath (overrides ^. customB9ConfigPath)-    action+type Cmd = B9ConfigAction IO () -parseCommandLine :: IO (B9RunParameters ())+applyB9RunParameters :: B9RunParameters -> IO ()+applyB9RunParameters (B9RunParameters overrides act vars) =+    let cfg =+            noB9ConfigOverride+                &  customB9Config+                %~ ( over envVars (++ vars)+                   . const (overrides ^. customB9Config)+                   )+                &  maybe id+                         overrideB9ConfigPath+                         (overrides ^. customB9ConfigPath)+    in  execB9ConfigAction act cfg++parseCommandLine :: IO B9RunParameters parseCommandLine = execParser     ( info         (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))@@ -38,8 +45,8 @@         )     )   where-    b9HelpHeader =-        linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)+    b9HelpHeader = linebreak+        <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)   globals :: Parser B9ConfigOverride@@ -125,37 +132,50 @@         = 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)-+              b9cfg =+                  mempty+                      &  verbosity+                      .~ minLogLevel+                      &  logFile+                      .~ logF+                      &  profileFile+                      .~ profF+                      &  buildDirRoot+                      .~ buildRoot+                      &  keepTempDirs+                      .~ keep+                      &  uniqueBuildDirs+                      .~ not notUnique+                      &  repository+                      .~ repo+                      &  repositoryCache+                      .~ (Path <$> mRepoCache)           in  B9ConfigOverride                   { _customB9ConfigPath = Path <$> cfg-                  , _customB9Config = b9cfg+                  , _customB9Config     = b9cfg                   } -cmds :: Parser (B9Invokation () ())+cmds :: Parser Cmd cmds = subparser     (  command           "version"-          ( info (pure (ignoreActionResults runShowVersion))+          ( info (pure runShowVersion)                  (progDesc "Show program version and exit.")           )     <> command            "build"            ( info-               (ignoreActionResults . runBuildArtifacts <$> buildFileParser)+               (void . runBuildArtifacts <$> buildFileParser)+                (progDesc "Merge all build file and generate all artifacts.")            )     <> command            "run"            ( info-               (ignoreActionResults <$> (runRun <$> sharedImageNameParser <*> many (strArgument idm)))+               (   (\x y -> void (runRun x y))+               <$> sharedImageNameParser+               <*> many (strArgument idm)+               )                ( progDesc                    "Run a command on the lastest version of the specified shared image. All modifications are lost on exit."                )@@ -163,7 +183,7 @@     <> command            "push"            ( info-               (ignoreActionResults . runPush <$> sharedImageNameParser)+               (runPush <$> sharedImageNameParser)                ( progDesc                    "Push the lastest shared image from cache to the selected  remote repository."                )@@ -171,7 +191,7 @@     <> command            "pull"            ( info-               (ignoreActionResults . runPull <$> optional sharedImageNameParser)+               (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."                )@@ -179,7 +199,7 @@     <> command            "clean-local"            ( info-               (pure (ignoreActionResults runGcLocalRepoCache))+               (pure runGcLocalRepoCache)                ( progDesc                    "Remove old versions of shared images from the local cache."                )@@ -187,23 +207,24 @@     <> command            "clean-remote"            ( info-               (pure (ignoreActionResults runGcRemoteRepoCache))+               (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 (ignoreActionResults runListSharedImages)) (progDesc "List shared images."))+           (info (pure (void runListSharedImages)) (progDesc "List shared images."))     <> command            "add-repo"-           ( info (ignoreActionResults . runAddRepo <$> remoteRepoParser)+           ( info (runAddRepo <$> remoteRepoParser)                   (progDesc "Add a remote repo.")            )     <> command            "reformat"-           ( info (ignoreActionResults . runFormatBuildFiles <$> buildFileParser)-                  (progDesc "Re-Format all build files.")+           ( info+               ( runFormatBuildFiles    <$> buildFileParser              )+               (progDesc "Re-Format all build files.")            )     ) @@ -267,4 +288,3 @@         <*> (   SharedImageName             <$> strArgument (help "Shared image name" <> metavar "NAME")             )-

@@ -25,25 +25,44 @@           , runLookupLocalSharedImage           , module X) where import Control.Applicative as X+import Control.Exception(throwIO, catch) import Control.Monad as X import Control.Monad.IO.Class as X-import Control.Exception(throwIO, catch)+import Control.Monad.Reader as X (ReaderT, local, ask)+import Control.Lens as X (Lens, (^.), (.~), (%~), (&)) import System.IO.Error (isDoesNotExistError) import System.Directory (removeFile)-import Data.Monoid as X+import Data.Function (on) import Data.List as X import Data.Maybe as X+import Data.Monoid as X import Text.Show.Pretty as X (ppShow) import System.Exit as X (exitWith, ExitCode(..)) import System.FilePath as X         (takeDirectory, takeFileName, replaceExtension, (</>), (<.>)) import Text.Printf as X (printf) import Data.Version as X-import B9.Builder as X-import B9.Invokation as X+import B9.B9Monad 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.ShellScript as X+import B9.Repository as X+import B9.RepositoryIO as X+import B9.ArtifactGenerator as X+import B9.ArtifactGeneratorImpl as X+import B9.Vm as X+import B9.VmBuilder as X+import B9.QCUtil as X+import B9.Content.AST as X+import B9.Content.StringTemplate as X+import B9.Content.ErlTerms as X+import B9.Content.ErlangPropList as X+import B9.Content.YamlObject as X+import B9.Content.Generator as X import Paths_b9 (version)-import Data.Function (on)-import Control.Lens as Lens ((^.), over, (.~), (%~), set)  -- | Return the cabal package version of the B9 library. b9Version :: Version@@ -54,50 +73,61 @@ b9VersionString :: String b9VersionString = showVersion version -runShowVersion :: B9Invokation Bool ()-runShowVersion = doAfterConfiguration $ const $ do-  liftIO $ putStrLn b9VersionString-  return True+-- | Just print the 'b9VersionString'+runShowVersion :: MonadIO m => m ()+runShowVersion = liftIO $ putStrLn b9VersionString -runBuildArtifacts :: [FilePath] -> B9Invokation String ()+-- | Execute the artifact generators defined in a list of text files.+-- Read the text files in the list and parse them as 'ArtifactGenerator's+-- then 'mappend' them and apply 'buildArtifacts' to them.+runBuildArtifacts :: MonadIO m => [FilePath] -> B9ConfigAction m String runBuildArtifacts buildFiles = do   generators <- mapM consult buildFiles-  buildArtifacts (mconcat generators)+  run (buildArtifacts (mconcat generators)) -runFormatBuildFiles :: [FilePath] -> B9Invokation Bool ()-runFormatBuildFiles buildFiles = doAfterConfiguration $ const $ liftIO $ do+-- | Read all text files and parse them as 'ArtifactGenerator's.+-- Then overwrite the files with their contents but _pretty printed_+-- (i.e. formatted).+runFormatBuildFiles :: MonadIO m => [FilePath] -> m ()+runFormatBuildFiles buildFiles = 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 Bool ()-runPush name = do-  modifyInvokationConfig (keepTempDirs .~ False)-  run $ const $ 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+  putStrLn `mapM` generatorsFormatted+  zipWithM_ writeFile buildFiles generatorsFormatted +-- | Upload a 'SharedImageName' to the default remote repository.+-- Note: The remote repository is specified in the 'B9Config'.+runPush :: MonadIO m => SharedImageName -> B9ConfigAction m ()+runPush name = localRuntimeConfig (keepTempDirs .~ False) $ run $ do+  conf <- getConfig+  if isNothing (conf ^. repository)+    then+      errorExitL+        "No repository specified! Use '-r' to specify a repo BEFORE 'push'."+    else+      pushSharedImageLatestVersion name -runPull :: Maybe SharedImageName -> B9Invokation Bool ()-runPull mName = do-  modifyInvokationConfig (keepTempDirs .~ False)-  run (const (pullRemoteRepos >> maybePullImage))-  where maybePullImage = maybe (return True) pullLatestImage mName+-- | Either pull a list of available 'SharedImageName's from the remote+-- repository if 'Nothing' is passed as parameter, or pull the latest version+-- of the image from the remote repository. Note: The remote repository is+-- specified in the 'B9Config'.+runPull :: MonadIO m => Maybe SharedImageName -> B9ConfigAction m ()+runPull mName =+  localRuntimeConfig (keepTempDirs .~ False)+                     (run (pullRemoteRepos >> maybePullImage))+  where maybePullImage =+          mapM_ (\name -> pullLatestImage name >>= failIfFalse name) mName+        failIfFalse _name True =+          return ()+        failIfFalse name False =+          errorExitL (printf "failed to pull: %s" (show name)) -runRun :: SharedImageName -> [String] -> B9Invokation String ()-runRun (SharedImageName name) cmdAndArgs = do-  modifyInvokationConfig-    (Lens.set keepTempDirs False . Lens.set interactive True)-  buildArtifacts runCmdAndArgs+-- | Execute an interactive root shell in a running container from a+-- 'SharedImageName'.+runRun :: MonadIO m => SharedImageName -> [String] -> B9ConfigAction m String+runRun (SharedImageName name) cmdAndArgs = localRuntimeConfig+  ((keepTempDirs .~ False) . (interactive .~ True))+  (run (buildArtifacts runCmdAndArgs))  where   runCmdAndArgs = Artifact     (IID ("run-" ++ name))@@ -111,28 +141,24 @@    where     cmdAndArgs' = if null cmdAndArgs then ["/usr/bin/zsh"] else cmdAndArgs --runGcLocalRepoCache :: B9Invokation Bool ()-runGcLocalRepoCache = do-  modifyInvokationConfig (keepTempDirs .~ False)-  impl+-- | Delete all obsolete versions of all 'SharedImageName's.+runGcLocalRepoCache :: MonadIO m => B9ConfigAction m ()+runGcLocalRepoCache = localRuntimeConfig (keepTempDirs .~ False) (run impl)  where-  impl = run $ const $ do-    toDelete <- (obsoleteSharedmages . map snd)-      <$> lookupSharedImages (== Cache) (const True)+  impl = do+    toDelete <- obsoleteSharedmages . map snd <$> lookupSharedImages+      (== Cache)+      (const True)     imgDir <- getSharedImagesCacheDir     let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)         infoFiles     = sharedImageFileName <$> toDelete-        imgFiles      = (imageFileName . sharedImageImage) <$> toDelete+        imgFiles      = imageFileName . sharedImageImage <$> toDelete     if null filesToDelete-      then liftIO $ do-        putStrLn "\n\nNO IMAGES TO DELETE\n"-        return True+      then liftIO $ putStrLn "\n\nNO IMAGES TO DELETE\n"       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@@ -143,56 +169,72 @@     handleExists e | isDoesNotExistError e = return ()                    | otherwise             = throwIO e -runGcRemoteRepoCache :: B9Invokation Bool ()-runGcRemoteRepoCache = do-  modifyInvokationConfig (keepTempDirs .~ False)-  run $ const $ do-    repos <- getSelectedRepos-    cache <- getRepoCache-    mapM_ (cleanRemoteRepo cache) repos-    return True+-- | Clear the shared image cache for a remote. Note: The remote repository is+-- specified in the 'B9Config'.+runGcRemoteRepoCache :: MonadIO m => B9ConfigAction m ()+runGcRemoteRepoCache = localRuntimeConfig+  (keepTempDirs .~ False)+  ( run+    ( do+      repos <- getSelectedRepos+      cache <- getRepoCache+      mapM_ (cleanRemoteRepo cache) repos+    )+  ) -runListSharedImages :: B9Invokation [SharedImage] ()-runListSharedImages = do-  modifyInvokationConfig (keepTempDirs .~ False)-  run $ const $ 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\+-- | Print a list of shared images cached locally or remotely, if a remote+-- repository was selected. Note: The remote repository is+-- specified in the 'B9Config'.+runListSharedImages :: MonadIO m => B9ConfigAction m [SharedImage]+runListSharedImages = localRuntimeConfig+  (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 $ map snd imgs-+        else liftIO $ putStrLn+          (  "Showing shared images on: "+          ++ remoteRepoRepoId (fromJust remoteRepo)+          )+      unless (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 (map snd imgs)+    )+  ) -runAddRepo :: RemoteRepo -> B9Invokation Bool ()+-- | Check the SSH settings for a remote repository and add it to the user wide+-- B9 configuration file.+runAddRepo :: MonadIO m => RemoteRepo -> B9ConfigAction m () runAddRepo repo = do   repo' <- remoteRepoCheckSshPrivKey repo   modifyPermanentConfig-    (  remoteRepos-    %~ ( mappend [repo']-       . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId)-       )+    ( Endo+      (  remoteRepos+      %~ ( mappend [repo']+         . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId)+         )+      )     ) +-- | Find the most recent version of a 'SharedImageName' in the local image cache. runLookupLocalSharedImage-  :: SharedImageName -> B9Invokation (Maybe SharedImageBuildId) ()-runLookupLocalSharedImage n = run $ const $ do+  :: MonadIO m => SharedImageName -> B9ConfigAction m (Maybe SharedImageBuildId)+runLookupLocalSharedImage n = run $ do   traceL (printf "Searching for cached image: %s" (show n))   imgs <- lookupSharedImages isAvailableOnLocalHost hasTheDesiredName   traceL "Candidate images: "

@@ -13,7 +13,6 @@ import B9.Content.StringTemplate import B9.Content.Generator import B9.Content.AST- import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as E@@ -32,6 +31,16 @@ import System.Directory import Text.Printf import Text.Show.Pretty (ppShow)++-- | Execute an 'ArtifactGenerator' and return a 'B9Invokation' that returns+-- the build id obtained by 'getBuildId'.+buildArtifacts :: ArtifactGenerator -> B9 String+buildArtifacts artifactGenerator = do+  traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory+  infoL "BUILDING ARTIFACTS"+  getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow+  assemble artifactGenerator+  getBuildId  -- | Return a list of relative paths for the /local/ files to be generated -- by the ArtifactGenerator. This excludes 'Shared' and Transient image targets.

@@ -17,8 +17,20 @@                    , libVirtLXCConfigs                    , remoteRepos                    , B9ConfigOverride(..)+                   , noB9ConfigOverride+                   , B9ConfigAction()+                   , execB9ConfigAction+                   , invokeB9+                   , askRuntimeConfig+                   , localRuntimeConfig+                   , modifyPermanentConfig                    , customB9Config                    , customB9ConfigPath+                   , overrideB9ConfigPath+                   , overrideB9Config+                   , overrideWorkingDirectory+                   , overrideVerbosity+                   , overrideKeepBuildDirs                    , defaultB9ConfigFile                    , defaultRepositoryCache                    , defaultB9Config@@ -38,16 +50,22 @@ import Data.Maybe (fromMaybe) import Control.Exception import Data.Function (on)+import Control.Lens as Lens (makeLenses, (^.), (.~), over, set)+import Control.Monad ((>=>)) import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Writer import System.Directory import qualified Data.Semigroup as Sem-import Data.Monoid import Data.List (partition, sortBy) import Data.ConfigFile.B9Extras+          ( SystemPath(..), ConfigParser, CPError, Get_C+          , OptionSpec, resolve, ensureDir, readIniFile+          , IniFileException(..), merge, to_string+          , add_section, emptyCP, setshow, get) import B9.B9Config.LibVirtLXC as X import B9.B9Config.Repository as X-import Control.Lens.TH-import Control.Monad ((>=>))+import Text.Printf (printf)  type BuildVariables = [(String,String)] @@ -98,11 +116,116 @@ data B9ConfigOverride = B9ConfigOverride   { _customB9ConfigPath :: Maybe SystemPath   , _customB9Config     :: B9Config-  }+  } deriving Show +-- | An empty default 'B9ConfigOverride' value, that will neither apply any+-- additional 'B9Config' nor change the path of the configuration file.+noB9ConfigOverride :: B9ConfigOverride+noB9ConfigOverride = B9ConfigOverride Nothing mempty+ makeLenses ''B9Config makeLenses ''B9ConfigOverride +-- | Convenience utility to override the B9 configuration file path.+overrideB9ConfigPath :: SystemPath -> B9ConfigOverride -> B9ConfigOverride+overrideB9ConfigPath p = customB9ConfigPath .~ Just p++-- | Modify the runtime configuration.+overrideB9Config+  :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride+overrideB9Config = over customB9Config++-- | Define the current working directory to be used when building.+overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride+overrideWorkingDirectory p = customB9Config . buildDirRoot .~ Just p+++-- | Overwrite the 'verbosity' settings in the configuration with those given.+overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride+overrideVerbosity = overrideB9Config . Lens.set verbosity . Just++-- | Overwrite the 'keepTempDirs' flag in the configuration with those given.+overrideKeepBuildDirs :: Bool -> B9ConfigOverride -> B9ConfigOverride+overrideKeepBuildDirs = overrideB9Config . Lens.set keepTempDirs++-- | A monad that gives access to the (transient) 'B9Config' to be used to+-- _runtime_ with 'askRuntimeConfig' or 'localRuntimeConfig', and that allows+-- to write permanent 'B9Config' changes back to the configuration file using+-- 'modifyPermanentConfig'. Execute a 'B9ConfigAction' by invoking+-- either 'invokeB9' (which is simple) or 'execB9ConfigAction'.+newtype B9ConfigAction m a = B9ConfigAction+  { runB9ConfigAction :: ReaderT B9Config (WriterT [Endo B9Config] m) a}+  deriving ( Functor, Applicative, Monad, MonadIO )++-- | Return the runtime configuration, that should be the configuration merged+-- from all configuration sources. This is the configuration to be used during+-- a VM image build.+askRuntimeConfig :: Monad m => B9ConfigAction m B9Config+askRuntimeConfig = B9ConfigAction ask++-- | Run an action with an updated runtime configuration.+localRuntimeConfig+  :: Monad m+  => (B9Config -> B9Config)+  -> B9ConfigAction m a+  -> B9ConfigAction m a+localRuntimeConfig f = B9ConfigAction . local f . runB9ConfigAction++-- | Add a modification to the permanent configuration file.+modifyPermanentConfig :: Monad m => Endo B9Config -> B9ConfigAction m ()+modifyPermanentConfig f = B9ConfigAction (tell [f])++-- | Execute a 'B9ConfigAction'.+-- It will take a 'B9ConfigOverride' as input. The 'B9Config' in that value is+-- treated as the _runtime_ configuration, and the '_customConfigPath' is used+-- as the alternative location of the configuration file.+-- The configuration file is read from either the path in '_customB9ConfigPath'+-- or from 'defaultB9ConfigFile'.+-- Every modification done via 'modifyPermanentConfig' is applied to+-- the **contents** of the configuration file+-- and written back to that file, note that these changes are ONLY reflected+-- in the configuration file and **not** in the _runtime configuration_.+--+-- See also 'invokeB9', which does not need the 'B9ConfigOverride' parameter.+execB9ConfigAction :: MonadIO m => B9ConfigAction m a -> B9ConfigOverride -> m a+execB9ConfigAction act cfg = do+  let cfgPath = cfg ^. customB9ConfigPath+  cp <- openOrCreateB9Config cfgPath++  case parseB9Config cp of+    Left e -> do+      fail+        ( printf "Internal configuration load error, please report this: %s\n"+                 (show e)+        )++    Right permanentConfig -> do+      let runtimeCfg = permanentConfig Sem.<> (cfg ^. customB9Config)+      (res, permanentB9ConfigUpdates) <- runWriterT+        (runReaderT (runB9ConfigAction act) runtimeCfg)++      let cpExtErr = modifyConfigParser cp <$> permanentB9ConfigUpdate+          permanentB9ConfigUpdate = if null permanentB9ConfigUpdates+            then Nothing+            else Just (mconcat permanentB9ConfigUpdates)+      cpExt <- maybe+        (return Nothing)+        ( either+          ( fail+          . printf+              "Internal configuration update error! Please report this: %s\n"+          . show+          )+          (return . Just)+        )+        cpExtErr+      mapM_ (writeB9ConfigParser (cfg ^. customB9ConfigPath)) cpExt+      return res+-- | Run a 'B9ConfigAction' using 'noB9ConfigOverride'.+-- See 'execB9ConfigAction' for more details.+invokeB9 :: MonadIO m => B9ConfigAction m a -> m a+invokeB9 = flip execB9ConfigAction noB9ConfigOverride+ -- | 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.@@ -115,7 +238,7 @@     if exists       then readIniFile (Path cfgFile)       else-        let res = b9ConfigToConfigParser defaultB9Config emptyCP+        let res = b9ConfigToConfigParser defaultB9Config         in  case res of               Left  e  -> throwIO (IniFileException cfgFile e)               Right cp -> writeFile cfgFile (to_string cp) >> return cp@@ -176,17 +299,16 @@  -- | Parse a 'B9Config', modify it, and merge it back to the given 'ConfigParser'. modifyConfigParser-  :: (B9Config -> B9Config) -> ConfigParser -> Either CPError ConfigParser-modifyConfigParser f cp = do+  :: ConfigParser -> Endo B9Config -> Either CPError ConfigParser+modifyConfigParser cp f = do   cfg <- parseB9Config cp-  cp2 <- b9ConfigToConfigParser (f cfg) emptyCP+  cp2 <- b9ConfigToConfigParser (appEndo f cfg)   return (merge cp cp2) --- | 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+-- | Append a config file section for the 'B9Config' to an empty 'ConfigParser'.+b9ConfigToConfigParser :: B9Config -> Either CPError ConfigParser+b9ConfigToConfigParser c = do+  cp1 <- add_section emptyCP cfgFileSection   cp2 <- setshow cp1 cfgFileSection verbosityK (_verbosity c)   cp3 <- setshow cp2 cfgFileSection logFileK (_logFile c)   cp4 <- setshow cp3 cfgFileSection buildDirRootK (_buildDirRoot c)

@@ -7,20 +7,18 @@ This module is used by the _effectful_ functions in this library. -} module B9.B9Monad-       (B9, run, traceL, dbgL, infoL, errorL, getConfig,+       (B9, run, traceL, dbgL, infoL, errorL, errorExitL, getConfig,         getBuildId, getBuildDate, getBuildDir, getExecEnvType,         getSelectedRemoteRepo, getRemoteRepos, getRepoCache, cmd)        where  import B9.B9Config-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 ()@@ -57,14 +55,14 @@              String   deriving (Eq,Show) -run :: (Maybe a -> B9 a) -> B9Invokation a ()-run actionFunction = doAfterConfiguration $ \previousResult -> do-  cfg <- ask++run :: MonadIO m => B9 a -> B9ConfigAction m a+run action = do+  cfg <- askRuntimeConfig   liftIO $ do     buildId <- generateBuildId     now     <- getCurrentTime-    let action = actionFunction previousResult-    withBuildDir cfg buildId (withLogFile cfg . runImpl action cfg buildId now)+    withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)  where   withLogFile cfg f = maybe     (f Nothing)@@ -72,38 +70,39 @@     (_logFile cfg)   withBuildDir cfg buildId =     bracket (createBuildDir cfg buildId) (removeBuildDir cfg)-  runImpl action 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 action)) ctx-    -- Write a profiling report-    when (isJust (_profileFile cfg)) $ writeFile-      (fromJust (_profileFile cfg))-      (unlines $ show <$> reverse (bsProf ctxOut))-    return r+  runImpl cfg buildId now buildDir logFileHandle =+    bracket getCurrentDirectory setCurrentDirectory $ \_ -> do+      traverse 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@@ -127,7 +126,7 @@       $ removeDirectoryRecursive buildDir   generateBuildId = printf "%08X" <$> (randomIO :: IO Word32)   -- Run the action build action-  wrappedAction action = do+  wrappedAction = do     startTime <- gets bsStartTime     r         <- action     now       <- liftIO getCurrentTime@@ -226,6 +225,9 @@ errorL :: String -> B9 () errorL = b9Log LogError +errorExitL :: String -> B9 ()+errorExitL e = b9Log LogError e >> fail e+ b9Log :: LogLevel -> String -> B9 () b9Log level msg = do   lv  <- gets $ _verbosity . bsCfg@@ -267,13 +269,3 @@        let durMS = IoActionDuration (stop `diffUTCTime` start)        modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx}        return res----------

@@ -1,41 +0,0 @@-{-# LANGUAGE GADTs #-}-{-|-Highest-level build functions and and B9-re-exports.--}-module B9.Builder (buildArtifacts, module X) where-import B9.B9Monad 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-import B9.ArtifactGenerator as X-import B9.ArtifactGeneratorImpl as X-import B9.Vm as X-import B9.VmBuilder as X-import B9.QCUtil as X-import B9.Content.AST as X-import B9.Content.StringTemplate as X-import B9.Content.ErlTerms as X-import B9.Content.ErlangPropList as X-import B9.Content.YamlObject as X-import B9.Content.Generator as X--import Text.Printf ( printf )-import Text.Show.Pretty (ppShow)-import Control.Monad.IO.Class-import System.Directory---- | Execute an 'ArtifactGenerator' and return a 'B9Invokation' that returns--- the build id obtained by 'getBuildId'.-buildArtifacts :: ArtifactGenerator -> B9Invokation String ()-buildArtifacts artifactGenerator = run $ const $ do-  traceL . ("CWD: " ++) =<< liftIO getCurrentDirectory-  infoL "BUILDING ARTIFACTS"-  getConfig >>= traceL . printf "USING BUILD CONFIGURATION: %v" . ppShow-  assemble artifactGenerator-  getBuildId

@@ -28,18 +28,17 @@ -- | A wrapper type around yaml values with a Semigroup instance useful for -- combining yaml documents describing system configuration like e.g. user-data. data YamlObject =-    YamlObject Data.Yaml.Value+    YamlObject {_fromYamlObject :: Data.Yaml.Value}     deriving (Eq,Data,Typeable,Generic)  instance Hashable YamlObject-instance Binary YamlObject instance NFData YamlObject -instance Binary Data.Yaml.Value where-  put = put . encode+instance Binary YamlObject where+  put = put . encode . _fromYamlObject   get = do     v <- get-    return $ fromJust $ decode v+    return $ YamlObject $ fromJust $ decode v  instance Read YamlObject where   readsPrec _ = readsYamlObject

@@ -1,161 +0,0 @@-module B9.Invokation ( B9Invokation()-                     , invokeB9-                     , overrideWorkingDirectory-                     , mergeAfterConfigurationActionResults-                     , ignoreActionResults-                     , 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 res a = B9Inv {runB9Invokation :: StateT (InternalState res) IO a}-  deriving (MonadState (InternalState res), Monad, Applicative, Functor, MonadIO)---- | Internal state of the 'B9Invokation'-data InternalState a = IS { _initialConfigOverride   :: B9ConfigOverride-                          , _permanentB9ConfigUpdate :: Maybe (ConfigParser -> Either CPError ConfigParser)-                          , _changeWorkingDirectory  :: Maybe FilePath-                          , _buildAction             :: Maybe (ReaderT B9Config IO a)-                          }--makeLenses ''InternalState--initialState :: InternalState a-initialState = IS (B9ConfigOverride Nothing mempty) Nothing Nothing Nothing---- | Run a 'B9Invokation'.--- If the user has no B9 config file yet, a default config file will be created.-invokeB9 :: B9Invokation res () -> IO (Maybe res)-invokeB9 act = do-    st <- execStateT (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 (sequence (st ^. buildAction)) runtimeCfg-                        )-                    )-            completeBuildAction---- | Add an action to be executed once the configuration has been done.--- The action will be called with the result of the previous action defined by--- this function. In case this is the first action added 'Nothing' is passed.-doAfterConfiguration :: (Maybe a -> ReaderT B9Config IO a) -> B9Invokation a ()-doAfterConfiguration action = buildAction %= appendOrSet-  where-    appendOrSet Nothing  = Just (action Nothing)-    appendOrSet (Just x) = Just (x >>= action . Just)---- | Combine the result of a given 'B9Invokation' and the results of the action--- defined by 'doAfterConfiguration' in the current state.-mergeAfterConfigurationActionResults-    :: (Maybe a -> Maybe b -> ReaderT B9Config IO b)-    -> B9Invokation a ()-    -> B9Invokation b ()-mergeAfterConfigurationActionResults f ba = do-    st <- liftIO $ execStateT (runB9Invokation ba) initialState-    let fb mbAction = Just $ do-            ma <- sequence (st ^. buildAction)-            mb <- sequence mbAction-            f ma mb-    buildAction %= fb---- | Ignore the results of the actions defined by 'doAfterConfiguration'.--- All actions will be executed, but the result will be replaced with '()'.-ignoreActionResults :: B9Invokation a () -> B9Invokation () ()-ignoreActionResults =-    mergeAfterConfigurationActionResults (const (const (return ())))---- | Override the B9 configuration path-overrideB9ConfigPath :: SystemPath -> B9Invokation a ()-overrideB9ConfigPath p = initialConfigOverride . customB9ConfigPath .= Just p---- | Override the current working directory during execution of the actions--- added with 'doAfterConfiguration'.-overrideWorkingDirectory :: FilePath -> B9Invokation a ()-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 a ()-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 a ()-modifyPermanentConfig g = permanentB9ConfigUpdate %= go-  where-    go Nothing  = go (Just return)-    go (Just f) = Just (\cp -> f cp >>= modifyConfigParser g)-----------------------------

@@ -5,11 +5,11 @@ import Development.Shake.FilePath import B9 --- | Convert a 'B9Invokation' action into a Shake 'Action'.-b9InvokationAction :: B9Invokation a () -> Action a-b9InvokationAction invokationAction = do-    mres <- liftIO (invokeB9 invokationAction)-    maybe (fail "ERROR: Internal error while invoking a b9 action!") return mres+-- | Convert a 'B9Invokation' action into a Shake 'Action'. This is just+-- an alias for 'execB9ConfigAction' since 'Action' is an instance of 'MonadIO'+-- and 'execB9ConfigAction' work on any .+b9InvokationAction :: B9ConfigAction Action a -> B9ConfigOverride -> Action a+b9InvokationAction = execB9ConfigAction  -- | An action that does the equivalent of -- @b9c build -f <b9file> -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@@@ -19,7 +19,8 @@ buildB9File b9Root b9File args = do     let f = b9Root </> b9File     need [f]-    b9InvokationAction $ do-        modifyInvokationConfig (appendPositionalArguments args)-        overrideWorkingDirectory b9Root-        runBuildArtifacts [f]+    invokeB9+        ( localRuntimeConfig+            (appendPositionalArguments args . (buildDirRoot .~ Just b9Root))+            (runBuildArtifacts [f])+        )

@@ -11,12 +11,11 @@ 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+enableSharedImageRules :: B9ConfigOverride -> Rules ()+enableSharedImageRules b9inv = addBuiltinRule noLint go  where   go :: SharedImageName      -> Maybe ByteString.ByteString@@ -49,7 +48,7 @@               result = RunResult change newBuildIdBin newBuildId           return result     where-      getImgBuildId = b9InvokationAction (runLookupLocalSharedImage nameQ)+      getImgBuildId = execB9ConfigAction (runLookupLocalSharedImage nameQ) b9inv        decodeBuildId :: ByteString.ByteString -> SharedImageBuildId       decodeBuildId = Binary.decode . LazyByteString.fromStrict@@ -62,7 +61,7 @@         rules <- getUserRules         case userRuleMatch rules imgMatch of           [] -> fail $ "No rules to build B9 shared image " ++ show nameQ ++ " found"-          [act] -> act+          [act] -> act b9inv           _rs  -> fail $ "Multiple rules for the B9 shared image " ++ show nameQ ++ " found"         where           imgMatch (SharedImageCustomActionRule name mkImage) =@@ -81,9 +80,9 @@ customSharedImageAction b9img customAction =   addUserRule (SharedImageCustomActionRule b9img customAction')   where-    customAction' = do+    customAction' b9inv = do       customAction-      mCurrentBuildId <- b9InvokationAction (runLookupLocalSharedImage b9img)+      mCurrentBuildId <- execB9ConfigAction (runLookupLocalSharedImage b9img) b9inv       putLoud (printf "Finished custom action, for %s, build-id is: %s"                       (show b9img) (show mCurrentBuildId))       maybe (errorSharedImageNotFound b9img) return mCurrentBuildId@@ -92,7 +91,7 @@ type instance RuleResult SharedImageName = SharedImageBuildId  data SharedImageCustomActionRule =-  SharedImageCustomActionRule SharedImageName (Action SharedImageBuildId)+  SharedImageCustomActionRule SharedImageName (B9ConfigOverride -> Action SharedImageBuildId)   deriving Typeable  errorSharedImageNotFound :: Monad m => SharedImageName -> m a

@@ -2,6 +2,7 @@ packages: - '.' extra-deps: []-resolver: lts-11.0+resolver: lts-11.3 allow-newer: true # pvp-bounds: lower+require-stack-version: ">=1.6.5"