b9 0.5.63 → 0.5.65

raw patch · 28 files changed

+2286/−1855 lines, 28 filesdep +monad-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monad-control

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−27
• b9.cabal +8/−3
• src/cli/Main.hs +13/−15
• src/lib/B9.hs +178/−187
• src/lib/B9/Artifact/Content.hs +10/−44
• src/lib/B9/Artifact/Content/AST.hs +38/−39
• src/lib/B9/Artifact/Content/Readable.hs +20/−23
• src/lib/B9/Artifact/Content/StringTemplate.hs +145/−95
• src/lib/B9/Artifact/Readable.hs +6/−1
• src/lib/B9/Artifact/Readable/Interpreter.hs +254/−222
• src/lib/B9/B9Config.hs +141/−96
• src/lib/B9/B9Config/LibVirtLXC.hs +2/−2
• src/lib/B9/B9Config/Repository.hs +4/−4
• src/lib/B9/B9Error.hs +95/−0
• src/lib/B9/B9Exec.hs +79/−0
• src/lib/B9/B9Logging.hs +105/−0
• src/lib/B9/B9Monad.hs +43/−277
• src/lib/B9/BuildInfo.hs +128/−0
• src/lib/B9/DiskImageBuilder.hs +336/−257
• src/lib/B9/Environment.hs +124/−56
• src/lib/B9/LibVirtLXC.hs +149/−172
• src/lib/B9/Repository.hs +82/−0
• src/lib/B9/RepositoryIO.hs +86/−96
• src/lib/B9/Shake/Actions.hs +14/−9
• src/lib/B9/Shake/SharedImageRules.hs +58/−74
• src/lib/B9/Vm.hs +29/−18
• src/lib/B9/VmBuilder.hs +39/−40
• src/tests/B9/ArtifactGeneratorImplSpec.hs +65/−98

@@ -1,44 +1,54 @@ # Changelog for B9 +## 0.5.65++* Refactor the B9 Monad to use `extensible-effects`++## 0.5.64++* Refactor and prepare for more drastic changes++* Fix runtime errors due to `undefined` values in the environment+ ## 0.5.63 -* Depend on `shake-0.17.6` to fix build errors +* Depend on `shake-0.17.6` to fix build errors  ## 0.5.62 -* Rewrite `B9.Shake.SharedImageRules` in line with -  Shake's example for custom rules  +* Rewrite `B9.Shake.SharedImageRules` in line with+  Shake's example for custom rules  * Replace `ConcatableSyntax` by using `Binary` instances, and also      * Remove/Inline `encodeSyntax` by using `Binary.encode`-    +     * Rename `decodeSyntax` to `decodeOrFail'` and delegate-      to `Binary.decodeOrFail`. -    +      to `Binary.decodeOrFail`. + * Add a newtype wrapper around `YamlObject` for **cloud-init** yaml documents   `CloudConfigYaml`-  +   This new type serves the purpose of add the `#cloud-config`-  line to the top of the generated yaml document, +  line to the top of the generated yaml document,   as [required by cloud-init](https://cloudinit.readthedocs.io/en/latest/topics/format.html#cloud-config-data).-  -  The `Binary` instance adds this **header line** and -  delegates the rendering of the yaml document to ++  The `Binary` instance adds this **header line** and+  delegates the rendering of the yaml document to   `YamlObject`.-  -* Remove the rendering of this header line in the `YamlObject` ++* Remove the rendering of this header line in the `YamlObject`   `Binary` instance. -* Rename `RenderYaml` to `RenderYamlObject` In order to prevent unexpected +* Rename `RenderYaml` to `RenderYamlObject` In order to prevent unexpected   runtime behaviour in code that uses this library.-  + * Introduce the type `Environment` that replaces the ubiquotus `[(String, String)]`   by a lazy `Text` based `HashMap`.-  -     * Add `appendPositionalArguments`-  ++     * Add `addLocalPositionalArguments`+ * Rename the previous `B9.Artifact.Content` to `B9.Artifact.Content`  * Introduce `ContentGenerator` as an open, extensible alternative@@ -46,21 +56,19 @@   `B9.Artifact.Content` * Rename-and-Split refactor `B9.ArtifactSource{Impl}` to `B9.Artifact.Generator.{..}` -* Move `CanRender` from `B9.Artifact.Content.AST` to `B9.Artifact.Content`    +* Move `CanRender` from `B9.Artifact.Content.AST` to `B9.Artifact.Content`  * Switch to lazy `Text`s and `ByteString`s where possible, since B9 might-  read/generate large files. -  -* Rename `CanRender` to `ToContentGenerator` -  and change the method signatur to return the new `ContentGenerator` type  +  read/generate large files. +* Rename `CanRender` to `ToContentGenerator`+  and change the method signatur to return the new `ContentGenerator` type+ * Fix spelling: Rename B9Invokation to B9Invocation-  + * Rename `FromAST` to `FromAST`  * Rearrange modules for content generation:-   - Introduce `Content.FromByteString` +   - Introduce `Content.FromByteString`  * Remove deprecated `Concatenation`-   - 

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.63+version:             0.5.65  synopsis:            A tool and library for building virtual machine images. @@ -80,9 +80,13 @@                    , B9.Artifact.Readable                    , B9.Artifact.Readable.Interpreter                    , B9.Artifact.Readable.Source+                   , B9.BuildInfo                    , B9.B9Config                    , B9.B9Config.LibVirtLXC                    , B9.B9Config.Repository+                   , B9.B9Error+                   , B9.B9Logging+                   , B9.B9Exec                    , B9.B9Monad                    , B9.DiskImageBuilder                    , B9.DiskImages@@ -120,6 +124,7 @@                    , filepath >= 1.4                    , hashable >= 1.2                    , lens >= 4+                   , monad-control >= 1.0 && < 1.1                    , mtl >= 2.2                    , time >= 1.6                    , parallel >= 3.2@@ -175,6 +180,7 @@                    , base >= 4.8 && < 5                    , directory >= 1.3                    , bytestring >= 0.10+                   , extensible-effects >= 5 && < 6                    , optparse-applicative >= 0.13                    , lens >= 4                    , text >= 1.2@@ -211,6 +217,7 @@   build-depends:     base >= 4.8 && < 5                    , b9                    , binary >= 0.8 && < 0.9+                   , extensible-effects >= 5 && < 6                    , hspec                    , hspec-expectations                    , QuickCheck >= 2.5@@ -220,8 +227,6 @@                    , unordered-containers >= 0.2                    , bytestring >= 0.10                    , text >= 1.2-  if !impl(ghc >= 8.0)-    build-depends: semigroups >= 0.18   default-extensions: TupleSections                     , GeneralizedNewtypeDeriving                     , DeriveDataTypeable

@@ -3,7 +3,7 @@   ) where  import           B9-import           Control.Lens                    (over, (&), (.~), (^.))+import           Control.Lens                    ((&), (.~), (^.)) import qualified Data.Text.Lazy                  as LazyT import           Options.Applicative             hiding (action) import           Options.Applicative.Help.Pretty hiding ((</>))@@ -17,21 +17,20 @@ -- as well as build parameters. data B9RunParameters =   B9RunParameters B9ConfigOverride-                  Cmd+                  (B9ConfigAction ())                   Environment -type Cmd = B9ConfigAction IO ()- hostNetworkMagicValue :: String hostNetworkMagicValue = "host"  applyB9RunParameters :: B9RunParameters -> IO () applyB9RunParameters (B9RunParameters overrides act vars) =   let cfg =-        noB9ConfigOverride & customB9Config %~ (over envVars (`mappend` vars) . const (overrides ^. customB9Config)) &+        noB9ConfigOverride &         customLibVirtNetwork .~ (overrides ^. customLibVirtNetwork) &-        maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath)-   in execB9ConfigAction act cfg+        maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath) &+        customEnvironment .~ vars+   in runB9ConfigActionWithOverrides act cfg  parseCommandLine :: IO B9RunParameters parseCommandLine =@@ -40,7 +39,7 @@        (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'. The current working directory is used as ${buildDirRoot} if not otherwise specified in the config file, or via the '-b' option." <>+          "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'. The current working directory is used as ${projectRoot} if not otherwise specified in the config file, or via the '-b' option." <>         headerDoc (Just b9HelpHeader)))   where     b9HelpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString)@@ -55,11 +54,10 @@   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. If not specified '.'. The path will be canonicalized and stored in ${buildDirRoot}." <>+          "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${projectRoot}." <>         short 'b' <>         long "build-root-dir" <>         metavar "DIRECTORY")) <*>@@ -85,20 +83,19 @@       -> Bool       -> Maybe FilePath       -> Maybe FilePath-      -> Maybe FilePath       -> Bool       -> Bool       -> Maybe FilePath       -> Maybe String       -> Maybe String       -> B9ConfigOverride-    toGlobalOpts cfg verbose quiet logF profF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet =+    toGlobalOpts cfg verbose quiet logF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet =       let minLogLevel             | verbose = Just LogTrace             | quiet = Just LogError             | otherwise = Nothing           b9cfg =-            mempty & verbosity .~ minLogLevel & logFile .~ logF & profileFile .~ profF & buildDirRoot .~ buildRoot &+            mempty & verbosity .~ minLogLevel & logFile .~ logF & projectRoot .~ buildRoot &             keepTempDirs .~ keep &             uniqueBuildDirs .~ not predictableBuildDir &             repository .~ repo &@@ -112,9 +109,10 @@                      then Nothing                      else Just n) <$>                 libvirtNet+            , _customEnvironment = mempty             } -cmds :: Parser Cmd+cmds :: Parser (B9ConfigAction ()) cmds =   subparser     (command "version" (info (pure runShowVersion) (progDesc "Show program version and exit.")) <>@@ -164,7 +162,7 @@         noArgError (ErrorMsg "No build file specified!")))  buildVars :: Parser Environment-buildVars = flip insertPositionalArguments mempty . fmap LazyT.pack <$> many (strArgument idm)+buildVars = flip addPositionalArguments mempty . fmap LazyT.pack <$> many (strArgument idm)  remoteRepoParser :: Parser RemoteRepo remoteRepoParser =

@@ -10,63 +10,73 @@     used to describe a B9 build.  -}+module B9+  ( b9Version+  , b9VersionString+  , runShowVersion+  , runBuildArtifacts+  , runFormatBuildFiles+  , runPush+  , runPull+  , runRun+  , runGcLocalRepoCache+  , runGcRemoteRepoCache+  , runListSharedImages+  , runAddRepo+  , runLookupLocalSharedImage+  , module X+  ) where -module B9 ( b9Version, b9VersionString-          , runShowVersion-          , runBuildArtifacts-          , runFormatBuildFiles-          , runPush-          , runPull-          , runRun-          , runGcLocalRepoCache-          , runGcRemoteRepoCache-          , runListSharedImages-          , runAddRepo-          , 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.Monad.Reader as X (ReaderT, local, ask)-import Control.Lens as X (Lens, (^.), (.~), (%~), (&))-import System.IO.Error (isDoesNotExistError)-import System.Directory (removeFile)-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 System.IO.B9Extras as X--- import B9.Artifact as X-import B9.Artifact.Readable as X-import B9.Artifact.Content as X-import B9.Artifact.Content.AST as X-import B9.Artifact.Content.CloudConfigYaml as X-import B9.Artifact.Content.ErlTerms as X-import B9.Artifact.Content.ErlangPropList as X-import B9.Artifact.Content.Readable as X-import B9.Artifact.Content.StringTemplate as X-import B9.Artifact.Content.YamlObject as X-import B9.Artifact.Readable.Interpreter as X-import B9.B9Monad 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.Vm as X-import B9.VmBuilder as X-import B9.QCUtil as X-import B9.Environment as X-import Paths_b9 (version)+import           B9.Artifact.Content                 as X+import           B9.Artifact.Content.AST             as X+import           B9.Artifact.Content.CloudConfigYaml as X+import           B9.Artifact.Content.ErlangPropList  as X+import           B9.Artifact.Content.ErlTerms        as X+import           B9.Artifact.Content.Readable        as X+import           B9.Artifact.Content.StringTemplate  as X+import           B9.Artifact.Content.YamlObject      as X+import           B9.Artifact.Readable                as X+import           B9.Artifact.Readable.Interpreter    as X+import           B9.B9Config                         as X+import           B9.B9Error                          as X+import           B9.B9Exec                           as X+import           B9.B9Logging                        as X+import           B9.B9Monad                          as X+import           B9.BuildInfo                        as X+import           B9.DiskImageBuilder                 as X+import           B9.DiskImages                       as X+import           B9.Environment                      as X+import           B9.ExecEnv                          as X+import           B9.QCUtil                           as X+import           B9.Repository                       as X+import           B9.RepositoryIO                     as X+import           B9.ShellScript                      as X+import           B9.Vm                               as X+import           B9.VmBuilder                        as X+import           Control.Applicative                 as X+import           Control.Exception                   (catch, throwIO)+import           Control.Lens                        as X (Lens, (%~), (&),+                                                           (.~), (^.))+import           Control.Monad                       as X+import           Control.Monad.IO.Class              as X+import           Control.Monad.Reader                as X (ReaderT, ask, local)+import           Data.Function                       (on)+import           Data.List                           as X+import           Data.Maybe                          as X+import           Data.Monoid                         as X+import           Data.Version                        as X+import           Paths_b9                            (version)+import           System.Directory                    (removeFile)+import           System.Exit                         as X (ExitCode (..),+                                                           exitWith)+import           System.FilePath                     as X (replaceExtension,+                                                           takeDirectory,+                                                           takeFileName, (<.>),+                                                           (</>))+import           System.IO.B9Extras                  as X+import           System.IO.Error                     (isDoesNotExistError)+import           Text.Printf                         as X (printf)+import           Text.Show.Pretty                    as X (ppShow)  -- | Return the cabal package version of the B9 library. b9Version :: Version@@ -84,169 +94,150 @@ -- | 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 :: [FilePath] -> B9ConfigAction String runBuildArtifacts buildFiles = do   generators <- mapM consult buildFiles-  run (buildArtifacts (mconcat generators))+  runB9 (buildArtifacts (mconcat generators))  -- | 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-  zipWithM_ writeFile buildFiles generatorsFormatted+runFormatBuildFiles buildFiles =+  liftIO $ do+    generators <- mapM consult buildFiles+    let generatorsFormatted = map ppShow (generators :: [ArtifactGenerator])+    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+runPush :: SharedImageName -> B9ConfigAction ()+runPush name =+  localB9Config (keepTempDirs .~ False) $+  runB9 $ do+    conf <- getConfig+    if isNothing (conf ^. repository)+      then errorExitL "No repository specified! Use '-r' to specify a repo BEFORE 'push'."+      else pushSharedImageLatestVersion name  -- | 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 >>= maybe (failPull name) (const (return ()))-    )-    mName-  failPull name = errorExitL (printf "failed to pull: %s" (show name))+runPull :: Maybe SharedImageName -> B9ConfigAction ()+runPull mName = localB9Config (keepTempDirs .~ False) (runB9 (pullRemoteRepos >> maybePullImage))+  where+    maybePullImage = mapM_ (\name -> pullLatestImage name >>= maybe (failPull name) (const (return ()))) mName+    failPull name = errorExitL (printf "failed to pull: %s" (show name))  -- | 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))-    ( 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+runRun :: SharedImageName -> [String] -> B9ConfigAction String+runRun (SharedImageName name) cmdAndArgs =+  localB9Config ((keepTempDirs .~ False) . (interactive .~ True)) (runB9 (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  -- | Delete all obsolete versions of all 'SharedImageName's.-runGcLocalRepoCache :: MonadIO m => B9ConfigAction m ()-runGcLocalRepoCache = localRuntimeConfig (keepTempDirs .~ False) (run impl)- where-  impl = 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 $ putStrLn "\n\nNO IMAGES TO DELETE\n"-      else liftIO $ do-        putStrLn "DELETING FILES:"-        putStrLn (unlines filesToDelete)-        mapM_ removeIfExists filesToDelete-   where-    obsoleteSharedmages :: [SharedImage] -> [SharedImage]-    obsoleteSharedmages =-      concatMap (tail . reverse) . filter ((> 1) . length) . groupBy-        ((==) `on` sharedImageName)-    removeIfExists :: FilePath -> IO ()-    removeIfExists fileName = removeFile fileName `catch` handleExists-     where-      handleExists e | isDoesNotExistError e = return ()-                     | otherwise             = throwIO e+runGcLocalRepoCache :: B9ConfigAction ()+runGcLocalRepoCache = localB9Config (keepTempDirs .~ False) (runB9 impl)+  where+    impl = 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 $ putStrLn "\n\nNO IMAGES TO DELETE\n"+        else liftIO $ do+               putStrLn "DELETING FILES:"+               putStrLn (unlines filesToDelete)+               mapM_ removeIfExists filesToDelete+      where+        obsoleteSharedmages :: [SharedImage] -> [SharedImage]+        obsoleteSharedmages = concatMap (tail . reverse) . filter ((> 1) . length) . groupBy ((==) `on` sharedImageName)+        removeIfExists :: FilePath -> IO ()+        removeIfExists fileName = removeFile fileName `catch` handleExists+          where+            handleExists e+              | isDoesNotExistError e = return ()+              | otherwise = throwIO e  -- | 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-    )-  )+runGcRemoteRepoCache :: B9ConfigAction ()+runGcRemoteRepoCache =+  localB9Config+    (keepTempDirs .~ False)+    (runB9+       (do repos <- getSelectedRepos+           cache <- getRepoCache+           mapM_ (cleanRemoteRepo cache) repos))  -- | 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.\n"-          putStrLn "To view the contents of a remote repo add"-          putStrLn "the '-r' switch with one of the remote"-          putStrLn "repository ids."-        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)-    )-  )+runListSharedImages :: B9ConfigAction [SharedImage]+runListSharedImages =+  localB9Config+    (keepTempDirs .~ False)+    (runB9+       (do MkSelectedRemoteRepo remoteRepo <- getSelectedRemoteRepo+           let repoPred = maybe (== Cache) ((==) . toRemoteRepository) remoteRepo+           allRepos <- getRemoteRepos+           if isNothing remoteRepo+             then liftIO $ do+                    putStrLn "Showing local shared images only.\n"+                    putStrLn "To view the contents of a remote repo add"+                    putStrLn "the '-r' switch with one of the remote"+                    putStrLn "repository ids."+             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)))  -- | 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 :: RemoteRepo -> B9ConfigAction () runAddRepo repo = do   repo' <- remoteRepoCheckSshPrivKey repo   modifyPermanentConfig-    ( Endo-      (  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-  :: 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: "-  traceL (printf "%s\n" (prettyPrintSharedImages (map snd imgs)))-  let res = extractNewestImageFromResults imgs-  traceL (printf "Returning result: %s" (show res))-  return res- where-  extractNewestImageFromResults =-    listToMaybe . map toBuildId . take 1 . reverse . map snd-    where toBuildId (SharedImage _ _ i _ _) = i-  isAvailableOnLocalHost = (Cache ==)-  hasTheDesiredName (SharedImage n' _ _ _ _) = n == n'+runLookupLocalSharedImage :: SharedImageName -> B9ConfigAction (Maybe SharedImageBuildId)+runLookupLocalSharedImage n =+  runB9 $ do+    traceL (printf "Searching for cached image: %s" (show n))+    imgs <- lookupSharedImages isAvailableOnLocalHost hasTheDesiredName+    traceL "Candidate images: "+    traceL (printf "%s\n" (prettyPrintSharedImages (map snd imgs)))+    let res = extractNewestImageFromResults imgs+    traceL (printf "Returning result: %s" (show res))+    return res+  where+    extractNewestImageFromResults = listToMaybe . map toBuildId . take 1 . reverse . map snd+      where+        toBuildId (SharedImage _ _ i _ _) = i+    isAvailableOnLocalHost = (Cache ==)+    hasTheDesiredName (SharedImage n' _ _ _ _) = n == n'

@@ -5,56 +5,22 @@ -- -- @since 0.5.62 module B9.Artifact.Content-  ( ContentGeneratorT(MkContentGeneratorT)-  , ContentGenerator-  , ByteStringGenerator-  , renderContentGenerator-  , ToContentGenerator (..)-  ) where--import B9.B9Monad (B9)-import B9.Environment-import Control.Applicative (Alternative)-import Control.Monad.Reader-import Data.ByteString.Lazy as Lazy---- | A monadic action that generates content by using the 'Environment'--- as additional input, e.g. when interpolating string templates.------ Most intersting is the fact the 'Semigroup' and 'Monoid' instances--- are available.------ @since 0.5.62-newtype ContentGeneratorT m a = MkContentGeneratorT-  { getContentGenerator :: EnvironmentReaderT m a-  } deriving (MonadTrans, Alternative, MonadReader Environment, MonadIO, Monad, Applicative, Functor)+  ( ByteStringGenerator+  , ToContentGenerator(..)+  )+where --- | A 'B9' action that generates content by using the 'Environment'--- as additional input, e.g. when interpolating string templates.------ @since 0.5.62-type ContentGenerator a = ContentGeneratorT B9 a+import           B9.B9Monad+import           Control.Eff+import           Data.ByteString.Lazy          as Lazy  -- | A 'B9' action that procuces a 'Lazy.ByteString'. -- -- @since 0.5.62-type ByteStringGenerator = ContentGenerator Lazy.ByteString--instance (Monad m, Semigroup a) => Semigroup (ContentGeneratorT m a) where-  l <> r = (<>) <$> l <*> r--instance (Monad m, Monoid a) => Monoid (ContentGeneratorT m a) where-  mempty = pure mempty+type ByteStringGenerator = B9 Lazy.ByteString  -- | Types whose values can be turned into a 'ContentGenerator' -- -- @since 0.5.62-class ToContentGenerator c where-    toContentGenerator :: c -> ByteStringGenerator---- | Execute a 'ContentGenerator'.--- The 'Environment' contains the bindings of any string template variables.------ @since 0.5.62-renderContentGenerator :: Environment -> ContentGenerator a -> B9 a-renderContentGenerator e = runEnvironmentReaderT e . getContentGenerator+class ToContentGenerator c a where+    toContentGenerator :: IsB9 e => c -> Eff e a

@@ -20,20 +20,23 @@ Another example is the OTP/Erlang sys.config for configuring OTP/Erlang releases. -} -module B9.Artifact.Content.AST ( FromAST(..)-                      , AST(..)-                      , decodeOrFail'-                      ) where+module B9.Artifact.Content.AST+  ( FromAST(..)+  , AST(..)+  , decodeOrFail'+  )+where +import           Control.Eff import           Control.Parallel.Strategies-import           Data.Binary (Binary)-import qualified Data.Binary as Binary-import qualified Data.ByteString.Lazy.Char8 as Lazy+import           Data.Binary                    ( Binary )+import qualified Data.Binary                   as Binary+import qualified Data.ByteString.Lazy.Char8    as Lazy import           Data.Data import           Data.Hashable-import           GHC.Generics (Generic)+import           GHC.Generics                   ( Generic ) import           Test.QuickCheck-+import           B9.B9Monad import           B9.Artifact.Content.StringTemplate import           B9.Artifact.Content import           B9.QCUtil@@ -42,14 +45,13 @@ -- This is like 'Binary.decodeOrFail' exception that it allows to add and extra -- error message decodeOrFail'-    :: Binary a-    => String -- ^ An arbitrary string for error messages-    -> Lazy.ByteString-    -> Either String a-decodeOrFail' errorMessage b =-  case Binary.decodeOrFail b of-    Left (_,_,e) -> Left (unwords [errorMessage, e])-    Right (_,_,a) -> Right a+  :: Binary a+  => String -- ^ An arbitrary string for error messages+  -> Lazy.ByteString+  -> Either String a+decodeOrFail' errorMessage b = case Binary.decodeOrFail b of+  Left  (_, _, e) -> Left (unwords [errorMessage, e])+  Right (_, _, a) -> Right a  -- | Describe how to create structured content that has a tree-like syntactic -- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines@@ -77,14 +79,14 @@     deriving (Read,Show,Typeable,Data,Eq,Generic)  instance Functor (AST c) where-  fmap f (AST a)          = AST (f a)-  fmap f (ASTObj x)       = ASTObj ((fmap . fmap . fmap) f x)-  fmap f (ASTArr x)       = ASTArr ((fmap . fmap) f x)-  fmap f (ASTMerge x)     = ASTMerge ((fmap . fmap) f x)-  fmap _ (ASTEmbed x)     = ASTEmbed x-  fmap _ (ASTString x)    = ASTString x-  fmap _ (ASTInt x)       = ASTInt x-  fmap _ (ASTParse x)     = ASTParse x+  fmap f (AST       a) = AST (f a)+  fmap f (ASTObj    x) = ASTObj ((fmap . fmap . fmap) f x)+  fmap f (ASTArr    x) = ASTArr ((fmap . fmap) f x)+  fmap f (ASTMerge  x) = ASTMerge ((fmap . fmap) f x)+  fmap _ (ASTEmbed  x) = ASTEmbed x+  fmap _ (ASTString x) = ASTString x+  fmap _ (ASTInt    x) = ASTInt x+  fmap _ (ASTParse  x) = ASTParse x  instance (Hashable c, Hashable a) => Hashable (AST c a) instance (Binary c, Binary a) => Binary (AST c a)@@ -93,19 +95,16 @@ -- | Types of values that describe content, that can be created from an 'AST'. class FromAST a  where     fromAST-        :: (ToContentGenerator c)-        => AST c a -> ContentGenerator a+        :: (IsB9 e, ToContentGenerator c Lazy.ByteString)+        => AST c a -> Eff e a  instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where-    arbitrary =-        oneof-            [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))-            , ASTArr <$> smaller (listOf arbitrary)-            , ASTMerge <$>-              sized-                  (\s ->-                        resize (max 2 s) (listOf (halfSize arbitrary)))-            , ASTEmbed <$> smaller arbitrary-            , ASTString <$> arbitrary-            , ASTParse <$> smaller arbitrary-            , AST <$> smaller arbitrary]+  arbitrary = oneof+    [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))+    , ASTArr <$> smaller (listOf arbitrary)+    , ASTMerge <$> sized (\s -> resize (max 2 s) (listOf (halfSize arbitrary)))+    , ASTEmbed <$> smaller arbitrary+    , ASTString <$> arbitrary+    , ASTParse <$> smaller arbitrary+    , AST <$> smaller arbitrary+    ]

@@ -3,11 +3,18 @@ -} module B9.Artifact.Content.Readable where -import Control.Monad.Trans (lift) import Control.Parallel.Strategies #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif+import B9.Artifact.Content+import B9.Artifact.Content.AST+import B9.Artifact.Content.CloudConfigYaml+import B9.Artifact.Content.ErlangPropList+import B9.Artifact.Content.StringTemplate+import B9.Artifact.Content.YamlObject+import B9.B9Logging+import B9.QCUtil import Control.Monad.IO.Class import Data.Binary as Binary import qualified Data.ByteString as Strict@@ -19,15 +26,6 @@ import System.Process import Test.QuickCheck -import B9.B9Monad-import B9.Artifact.Content-import B9.Artifact.Content.AST-import B9.Artifact.Content.CloudConfigYaml-import B9.Artifact.Content.ErlangPropList-import B9.Artifact.Content.StringTemplate-import B9.Artifact.Content.YamlObject-import B9.QCUtil- -- | This is content that can be 'read' via the generated 'Read' instance. data Content   = RenderErlang (AST Content ErlangPropList)@@ -67,7 +65,7 @@       , FromURL <$> smaller arbitrary       ] -instance ToContentGenerator Content where+instance ToContentGenerator Content Lazy.ByteString where   toContentGenerator (RenderErlang ast) = Binary.encode <$> fromAST ast   toContentGenerator (RenderYamlObject ast) = Binary.encode <$> fromAST ast   toContentGenerator (RenderCloudConfig ast) = Binary.encode <$> fromAST ast@@ -79,15 +77,14 @@   toContentGenerator (RenderBase64Binary b) = pure (Lazy.fromStrict $ B64.encode $ Lazy.toStrict b)   toContentGenerator (FromString str) = pure (Lazy.pack str)   toContentGenerator (FromByteString str) = pure str-  toContentGenerator (FromURL url) =-    lift $ do-      dbgL $ "Downloading: " ++ url-      (exitCode, out, err) <- liftIO $ readProcessWithExitCode "curl" [url] ""-      if exitCode == ExitSuccess-        then do-          dbgL $ "Download finished. Bytes read: " ++ show (length out)-          traceL $ "Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n"-          pure $ Lazy.pack out-        else do-          errorL $ "Download failed: " ++ err-          liftIO $ exitWith exitCode+  toContentGenerator (FromURL url) = do+    dbgL ("Downloading: " ++ url)+    (exitCode, out, err) <- liftIO (readProcessWithExitCode "curl" [url] "")+    if exitCode == ExitSuccess+      then do+        dbgL ("Download finished. Bytes read: " ++ show (length out))+        traceL ("Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n")+        pure (Lazy.pack out)+      else do+        errorL ("Download failed: " ++ err)+        liftIO (exitWith exitCode)

@@ -1,42 +1,47 @@ {-# LANGUAGE FlexibleContexts #-}  {-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable-    expansion in string throughout a B9 artifact. -}+    expansion in string throughout a B9 artifact.++    @deprecated++    TODO remove this in the move to Dhall+    -} module B9.Artifact.Content.StringTemplate   ( subst-  , substE-  , substEB   , substFile   , substPath   , readTemplateFile+  , withSubstitutedStringBindings   , SourceFile(..)   , SourceFileConversion(..)-  ) where-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import B9.Environment-import B9.QCUtil-import Control.Exception (SomeException)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Reader (runReaderT)-import Control.Monad.Trans.Identity ()-import Control.Parallel.Strategies-import Data.Bifunctor-import Data.Binary-import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as Lazy-import Data.Data-import Data.Hashable-import qualified Data.Text.Lazy as LazyT-import qualified Data.Text      as StrictT-import qualified Data.Text.Encoding       as StrictE-import qualified Data.Text.Lazy.Encoding  as LazyE-import Data.Text.Template (render, renderA, templateSafe)-import GHC.Generics (Generic)-import System.IO.B9Extras-import Test.QuickCheck-import Text.Printf+  )+where+import           B9.B9Error+import           B9.Environment+import           B9.QCUtil+import           Control.Exception              ( displayException )+import           Control.Monad                  ( foldM )+import           Control.Monad.IO.Class         ( MonadIO(liftIO) )+import           Control.Eff                   as Eff+import           Control.Monad.Trans.Identity   ( )+import           Control.Parallel.Strategies+import           Data.Binary+import qualified Data.ByteString               as Strict+import qualified Data.ByteString.Lazy          as Lazy+import           Data.Data+import           Data.Hashable+import qualified Data.Text.Lazy                as LazyT+import qualified Data.Text                     as StrictT+import qualified Data.Text.Encoding            as StrictE+import qualified Data.Text.Lazy.Encoding       as LazyE+import           Data.Text.Template             ( renderA+                                                , templateSafe+                                                )+import           GHC.Generics                   ( Generic )+import           System.IO.B9Extras+import           Test.QuickCheck+import           Text.Printf  -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents.@@ -62,86 +67,131 @@  instance NFData SourceFileConversion -readTemplateFile :: (MonadIO m, MonadEnvironment m) => SourceFile -> m Lazy.ByteString+readTemplateFile+  :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e)+  => SourceFile+  -> Eff e Lazy.ByteString readTemplateFile (Source conv f') = do-  env <- askEnvironment-  case substE env f' of-    Left e ->-      error-        (printf-           "Failed to substitute templates in source \-                    \file name '%s'/\nError: %s\n"-           f'-           e)-    Right f -> do-      c <- liftIO (Lazy.readFile f)-      convert f c-  where-    convert f c =-      case conv of-        NoConversion -> return c-        ExpandVariables -> do-          env <- askEnvironment-          case substEB env c of-            Left e -> error (printf "readTemplateFile '%s' failed: \n%s\n" f e)-            Right c' -> return c'---- String template substitution via dollar-subst :: Environment -> String -> String-subst env templateStr =-  case substE env templateStr of-    Left e -> error e-    Right r -> r+  let+    onErrorFileName e = error+      (printf+        "Failed to substitute templates in source \+                                    \file name '%s'/\nError: %s\n"+        f'+        (displayException e)+      )+  f <- subst f' `catchB9Error` onErrorFileName+  c <- liftIO (Lazy.readFile f)+  case conv of+    NoConversion -> return c+    ExpandVariables ->+      let onErrorFile e =+              error+                (printf "readTemplateFile '%s' failed: \n%s\n"+                        f+                        (displayException e)+                )+      in  substEB c `catchB9Error` onErrorFile  -- String template substitution via dollar-substE :: Environment -> String -> Either String String-substE env templateStr = second (LazyT.unpack . LazyE.decodeUtf8) (substEB env (LazyE.encodeUtf8 (LazyT.pack templateStr)))+subst :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String+subst templateStr = LazyT.unpack . LazyE.decodeUtf8 <$> substEB+  (LazyE.encodeUtf8 (LazyT.pack templateStr))  -- String template substitution via dollar-substEB :: Environment -> Lazy.ByteString -> Either String Lazy.ByteString-substEB env templateStr = do+substEB+  :: (Member ExcB9 e, Member EnvironmentReader e)+  => Lazy.ByteString+  -> Eff e Lazy.ByteString+substEB templateStr = do   t <- template'-  res <- renderA t env'-  return (LazyE.encodeUtf8 res)-  where-    env' t =-      case lookupEither (LazyT.fromStrict t) env of-        Right v -> Right (LazyT.toStrict v)-        Left e -> Left (show e ++ "\nIn template: \"" ++ show templateStr ++ "\"\n")-    template' =-      case templateSafe (LazyT.toStrict (LazyE.decodeUtf8 templateStr)) of-        Left (row, col) ->-          Left-            ("Invalid template, error at row: " ++ show row ++ ", col: " ++ show col ++ " in: \"" ++ show templateStr)-        Right t -> Right t+  LazyE.encodeUtf8 <$> renderA t templateEnvLookup+ where+  templateEnvLookup+    :: (Member EnvironmentReader e, Member ExcB9 e)+    => StrictT.Text+    -> Eff e StrictT.Text+  templateEnvLookup x = LazyT.toStrict <$> lookupOrThrow (LazyT.fromStrict x) -substFile :: MonadIO m => Environment -> FilePath -> FilePath -> m ()-substFile env src dest = do+  template' =+    case templateSafe (LazyT.toStrict (LazyE.decodeUtf8 templateStr)) of+      Left (row, col) -> throwB9Error+        (  "Invalid template, error at row: "+        ++ show row+        ++ ", col: "+        ++ show col+        ++ " in: \""+        ++ show templateStr+        )+      Right t -> return t++substFile+  :: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))+  => FilePath+  -> FilePath+  -> Eff e ()+substFile src dest = do   templateBs <- liftIO (Strict.readFile src)   let t = templateSafe (StrictE.decodeUtf8 templateBs)   case t of     Left (r, c) ->-      let badLine = unlines (take r (lines (StrictT.unpack (StrictE.decodeUtf8 templateBs))))+      let badLine =+              unlines+                (take r (lines (StrictT.unpack (StrictE.decodeUtf8 templateBs))))           colMarker = replicate (c - 1) '-' ++ "^"-       in error (printf "Template error in file '%s' line %i:\n\n%s\n%s\n" src r badLine colMarker)+      in  throwB9Error+            (printf "Template error in file '%s' line %i:\n\n%s\n%s\n"+                    src+                    r+                    badLine+                    colMarker+            )     Right template' -> do-      let out = LazyE.encodeUtf8 (render template' envLookup)+      out <- LazyE.encodeUtf8+        <$> renderA template' (templateEnvLookupSrcFile src)       liftIO (Lazy.writeFile dest out)-      return ()-  where-    envLookup :: StrictT.Text -> StrictT.Text-    envLookup x = either err LazyT.toStrict (runReaderT (lookupOrThrow (LazyT.fromStrict x)) env)-      where-        err :: SomeException -> a-        err e = error (show e ++ "\nIn file: \'" ++ src ++ "\'\n") -substPath :: Environment -> SystemPath -> SystemPath-substPath env src =-  case src of-    Path p -> Path (subst env p)-    InHomeDir p -> InHomeDir (subst env p)-    InB9UserDir p -> InB9UserDir (subst env p)-    InTempDir p -> InTempDir (subst env p)+templateEnvLookupSrcFile+  :: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))+  => FilePath+  -> StrictT.Text+  -> Eff e StrictT.Text+templateEnvLookupSrcFile src x = do+  r <- catchB9ErrorAsEither (lookupOrThrow (LazyT.fromStrict x))+  either err (pure . LazyT.toStrict) r+  where err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n") ++substPath+  :: (Member EnvironmentReader e, Member ExcB9 e)+  => SystemPath+  -> Eff e SystemPath+substPath src = case src of+  Path        p -> Path <$> subst p+  InHomeDir   p -> InHomeDir <$> subst p+  InB9UserDir p -> InB9UserDir <$> subst p+  InTempDir   p -> InTempDir <$> subst p+ instance Arbitrary SourceFile where-  arbitrary = Source <$> elements [NoConversion, ExpandVariables] <*> smaller arbitraryFilePath+  arbitrary =+    Source+      <$> elements [NoConversion, ExpandVariables]+      <*> smaller arbitraryFilePath+++-- | Extend an 'Environment' with new bindings, where each value may contain+-- string templates with like @"Hello $name, how is life on $planet these days?"@.+--+-- @since 0.5.64+withSubstitutedStringBindings+  :: (Member EnvironmentReader e, Member ExcB9 e)+  => [(String, String)]+  -> Eff e s+  -> Eff e s+withSubstitutedStringBindings bs nested = do+  let extend env (k, v) = localEnvironment (const env) $ do+        kv <- (k, ) <$> subst v+        addStringBinding kv env+  env    <- askEnvironment+  envExt <- foldM extend env bs+  localEnvironment (const envExt) nested

@@ -66,6 +66,7 @@ These variables can be used as value in nested 'Let's, in most file names/paths and in source files added with 'B9.Artifact.Content.StringTemplate.SourceFile' +-- @deprecated TODO remove this when switching to Dhall -} data ArtifactGenerator   = Sources [ArtifactSource]@@ -76,6 +77,7 @@         [ArtifactGenerator]       -- ^ Bind variables, variables are available in nested       -- generators.+      -- @deprecated TODO remove this when switching to Dhall   | LetX [(String, [String])]          [ArtifactGenerator]       -- ^ A 'Let' where each variable is assigned to each@@ -97,6 +99,7 @@       --       Let [("x", "3"), ("y", "b")] [..]       --     ]       -- @+      -- @deprecated TODO remove this when switching to Dhall   | Each [(String, [String])]          [ArtifactGenerator]       -- ^ Bind each variable to their first value, then each@@ -105,6 +108,7 @@       -- product of all variables, whereas 'Each' represents a       -- sum of variable bindings - 'Each' is more like a /zip/       -- whereas 'LetX' is more like a list comprehension.+      -- @deprecated TODO remove this when switching to Dhall   | EachT [String]           [[String]]           [ArtifactGenerator]@@ -112,6 +116,7 @@       -- in the first list to each a set of values from the       -- second argument; execute the nested generators for       -- each binding+      -- @deprecated TODO remove this when switching to Dhall   | Artifact InstanceId              ArtifactAssembly       -- ^ Generate an artifact defined by an@@ -181,7 +186,7 @@  instance NFData ArtifactAssembly --- | A type representing the targets assembled by+-- | A symbolic representation of the targets assembled by -- 'B9.Artifact.Readable.Interpreter.assemble' from an 'ArtifactAssembly'. There is a -- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce up to -- three output files, a directory, an ISO image and a VFAT image.

@@ -1,39 +1,51 @@ {-| Mostly effectful functions to assemble artifacts. -}-module B9.Artifact.Readable.Interpreter where--import           Control.Arrow-import           Control.Exception         (Exception, SomeException)-import           Control.Lens              (view)-import           Control.Monad.Catch-import           Control.Monad.Except-import           Control.Monad.Reader-import           Control.Monad.Writer-import qualified Data.ByteString.Lazy      as Lazy-import           Data.Data-import           Data.Generics.Aliases-import           Data.Generics.Schemes-import           Data.List-import           Data.Maybe-import qualified Data.Text.Lazy            as LazyT-import qualified Data.Text.Lazy.Encoding   as LazyE-import           System.Directory-import           System.FilePath-import           System.IO.B9Extras        (ensureDir, getDirectoryFiles)-import           Text.Printf-import           Text.Show.Pretty          (ppShow)+module B9.Artifact.Readable.Interpreter+  ( buildArtifacts+  , assemble+  , getArtifactOutputFiles+  , runArtifactGenerator+  , runArtifactAssembly+  , InstanceGenerator(..)+  , runInstanceGenerator+  , InstanceSources(..)+  ) where -import           B9.Artifact.Readable-import           B9.B9Config-import           B9.B9Monad-import           B9.Artifact.Content-import           B9.Artifact.Content.Readable-import           B9.Artifact.Content.StringTemplate-import           B9.DiskImageBuilder-import           B9.Environment-import           B9.Vm-import           B9.VmBuilder+import B9.Artifact.Content+import B9.Artifact.Content.Readable+import B9.Artifact.Content.StringTemplate+import B9.Artifact.Readable+import B9.B9Config+import B9.B9Error+import B9.B9Exec+import B9.B9Logging+import B9.B9Monad+import B9.BuildInfo+import B9.DiskImageBuilder+import B9.Environment+import B9.Vm+import B9.VmBuilder+import Control.Arrow+import Control.Eff as Eff+import Control.Eff.Reader.Lazy as Eff+import Control.Eff.Writer.Lazy as Eff+import Control.Exception (SomeException, displayException)+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as Lazy+import Data.Data+import Data.Generics.Aliases+import Data.Generics.Schemes+import Data.List+import Data.String+import qualified Data.Text.Lazy as LazyT+import qualified Data.Text.Lazy.Encoding as LazyE+import System.Directory+import System.FilePath+import System.IO.B9Extras (ensureDir, getDirectoryFiles)+import Text.Printf+import Text.Show.Pretty (ppShow)  -- | Execute an 'ArtifactGenerator' and return a 'B9Invocation' that returns -- the build id obtained by 'getBuildId'.@@ -47,120 +59,148 @@  -- | Return a list of relative paths for the /local/ files to be generated -- by the ArtifactGenerator. This excludes 'Shared' and Transient image targets.-getArtifactOutputFiles :: ArtifactGenerator -> Either String [FilePath]-getArtifactOutputFiles g = concatMap getOutputs <$> evalArtifactGenerator undefined undefined mempty g+getArtifactOutputFiles :: ArtifactGenerator -> Either SomeException [FilePath]+getArtifactOutputFiles g = concatMap getOutputs <$> runArtifactGenerator mempty "no build-id" "no build-date" g   where     getOutputs (IG _ sgs a) =       let toOutFile (AssemblyGeneratesOutputFiles fs) = fs           toOutFile (AssemblyCopiesSourcesToDirectory pd) =-            let sourceFiles = sourceGeneratorOutputFile <$> sgs+            let sourceFiles = textFileWriterOutputFile <$> sgs              in (pd </>) <$> sourceFiles        in getAssemblyOutput a >>= toOutFile  -- | Run an artifact generator to produce the artifacts. assemble :: ArtifactGenerator -> B9 [AssembledArtifact] assemble artGen = do-  b9cfgEnvVars <- view envVars <$> getConfig+  b9cfgEnvVars <- askEnvironment   buildId <- getBuildId   buildDate <- getBuildDate-  case evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen of-    Left err -> error err-    Right is -> createAssembledArtifacts is+  runArtifactSourcesReader (InstanceSources b9cfgEnvVars mempty) $ do+    is <- evalArtifactGenerator buildId buildDate artGen+    createAssembledArtifacts is +-- | Interpret an 'ArtifactGenerator' into a list of simple commands, i.e. 'InstanceGenerator's+--+-- @since 0.5.65+runArtifactGenerator ::+     Environment -> String -> String -> ArtifactGenerator -> Either SomeException [InstanceGenerator [TextFileWriter]]+runArtifactGenerator initialEnvironment buildId buildData generator =+  Eff.run+    (runExcB9+       (runEnvironmentReader+          initialEnvironment+          (runArtifactSourcesReader+             (InstanceSources initialEnvironment mempty)+             (evalArtifactGenerator buildId buildData generator))))+ -- | Evaluate an 'ArtifactGenerator' into a list of low-level build instructions -- that can be built with 'createAssembledArtifacts'. evalArtifactGenerator ::-     String -> String -> Environment -> ArtifactGenerator -> Either String [InstanceGenerator [SourceGenerator]]-evalArtifactGenerator buildId buildDate b9cfgEnvVars artGen =-  let ag = parseArtifactGenerator artGen-      ee = addBindings [(buildDateKey, buildDate), (buildIdKey, buildId)] $ CGEnv b9cfgEnvVars []-   in case ee of-        Left err -> Left (printf "error parsing: %s: %s" (ppShow artGen) (show err))-        Right e ->-          case execCGParser ag e of-            Left err -> Left (printf "error parsing: %s: %s" (ppShow artGen) (show err))-            Right igs ->-              case execIGEnv `mapM` igs of-                Left err -> Left (printf "Failed to parse:\n%s\nError: %s" (ppShow artGen) err)-                Right is -> Right is---- | Parse an artifacto generator inside a 'CGParser' monad.-parseArtifactGenerator :: ArtifactGenerator -> CGParser ()-parseArtifactGenerator g =-  case g of-    Sources srcs gs -> withArtifactSources srcs (mapM_ parseArtifactGenerator gs)-    Let bs gs -> withBindings bs (mapM_ parseArtifactGenerator gs)-    LetX bs gs -> withXBindings bs (mapM_ parseArtifactGenerator gs)-    EachT keySet valueSets gs -> do-      allBindings <- eachBindingSetT g keySet valueSets-      sequence_ (flip withBindings (mapM_ parseArtifactGenerator gs) <$> allBindings)-    Each kvs gs -> do-      allBindings <- eachBindingSet g kvs-      sequence_ $ do-        b <- allBindings-        return (withBindings b (mapM_ parseArtifactGenerator gs))-    Artifact iid assembly -> writeInstanceGenerator iid assembly-    EmptyArtifact -> return ()---- | Execute a 'CGParser' action in an environment that contains a list of--- 'ArtifactSource's.-withArtifactSources :: [ArtifactSource] -> CGParser () -> CGParser ()-withArtifactSources srcs = local (\ce -> ce {agSources = agSources ce ++ srcs})+     (Member ExcB9 e, Member EnvironmentReader e)+  => String+  -> String+  -> ArtifactGenerator+  -> Eff (ArtifactSourcesReader ': e) [InstanceGenerator [TextFileWriter]]+evalArtifactGenerator buildId buildDate artGen =+  withSubstitutedStringBindings+    [(buildDateKey, buildDate), (buildIdKey, buildId)]+    (runArtifactInterpreter (interpretGenerator artGen)) `catchB9Error`+  (throwB9Error . printf "Failed to eval:\n%s\nError: %s" (ppShow artGen) . displayException) -withBindings :: [(String, String)] -> CGParser () -> CGParser ()-withBindings bs = local (fromJust . addBindings bs)+type ArtifactSourcesReader = Reader [ArtifactSource] -addBindings :: MonadThrow m => [(String, String)] -> CGEnv -> m CGEnv-addBindings bs ce = do-  let addBinding env (k, v) = addStringBinding (k, subst env v) env-  newEnv <- foldM addBinding (agEnv ce) bs-  return ce {agEnv = newEnv}+runArtifactSourcesReader ::+     Member EnvironmentReader e => InstanceSources -> Eff (ArtifactSourcesReader ': e) a -> Eff e a+runArtifactSourcesReader x y = runReader (isSources x) (localEnvironment (const (isEnv x)) y) -withXBindings :: [(String, [String])] -> CGParser () -> CGParser ()-withXBindings bs cp = (`local` cp) `mapM_` (((.) . (.)) fromJust addBindings <$> allXBindings bs)-  where-    allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs, c <- allXBindings rest]-    allXBindings [] = [[]]+-- | Monad for creating Instance generators.+type ArtifactInterpreter e = Writer [InstanceGenerator InstanceSources] : ArtifactSourcesReader : e -eachBindingSetT :: ArtifactGenerator -> [String] -> [[String]] -> CGParser [[(String, String)]]-eachBindingSetT g vars valueSets =-  if all ((== length vars) . length) valueSets-    then return (zip vars <$> valueSets)-    else cgError-           (printf-              "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"-              (ppShow g)-              (ppShow vars)-              (length vars)-              (ppShow (head (dropWhile ((== length vars) . length) valueSets))))+runArtifactInterpreter ::+     (Member ExcB9 e, Member EnvironmentReader e)+  => Eff (ArtifactInterpreter e) ()+  -> Eff (ArtifactSourcesReader : e) [InstanceGenerator [TextFileWriter]]+runArtifactInterpreter ai = do+  ((), igs) <- runMonoidWriter ai+  traverse toFileInstanceGenerator igs -eachBindingSet :: ArtifactGenerator -> [(String, [String])] -> CGParser [[(String, String)]]-eachBindingSet g kvs = do-  checkInput-  return bindingSets+-- | Parse an 'ArtifactGenerator' inside the 'ArtifactInterpreter' effect.+interpretGenerator ::+     (Member ExcB9 e, Member EnvironmentReader e) => ArtifactGenerator -> Eff (ArtifactInterpreter e) ()+interpretGenerator generatorIn =+  case generatorIn of+    Sources sources generators -> withArtifactSources sources (mapM_ interpretGenerator generators)+    Let bindings generators -> withSubstitutedStringBindings bindings (mapM_ interpretGenerator generators)+    LetX bindings generators -> withXBindings bindings (mapM_ interpretGenerator generators)+    EachT keySet valueSets generators -> do+      allBindings <- eachBindingSetT generatorIn keySet valueSets+      sequence_ (flip withSubstitutedStringBindings (mapM_ interpretGenerator generators) <$> allBindings)+    Each kvs generators -> do+      allBindings <- eachBindingSet generatorIn kvs+      sequence_ $ do+        b <- allBindings+        return (withSubstitutedStringBindings b (mapM_ interpretGenerator generators))+    Artifact iid assembly -> interpretAssembly iid assembly+    EmptyArtifact -> return ()   where-    bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]-    checkInput =-      when-        (1 /= length (nub $ length . snd <$> kvs))-        (cgError (printf "Error in 'Each' binding: \n%s\nAll value lists must have the same length!" (ppShow g)))--writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser ()-writeInstanceGenerator (IID iidStrT) assembly = do-  env@(CGEnv bindings _) <- ask-  iid <- either (throwM . CGError) (return . IID) (substE bindings iidStrT)-  let IID iidStr = iid-  env' <- addBindings [(instanceIdKey, iidStr)] env-  tell [IG iid env' assembly]+    withArtifactSources ::+         (Member ExcB9 e, Member EnvironmentReader e)+      => [ArtifactSource]+      -> Eff (ArtifactInterpreter e) s+      -> Eff (ArtifactInterpreter e) s+    withArtifactSources sources = local (++ sources)+    withXBindings ::+         (Member ExcB9 e, Member EnvironmentReader e)+      => [(String, [String])]+      -> Eff (ArtifactInterpreter e) ()+      -> Eff (ArtifactInterpreter e) ()+    withXBindings bindings cp = (`withSubstitutedStringBindings` cp) `mapM_` allXBindings bindings+      where+        allXBindings ((k, vs):rest) = [(k, v) : c | v <- vs, c <- allXBindings rest]+        allXBindings [] = [[]]+    eachBindingSetT ::+         (Member ExcB9 e)+      => ArtifactGenerator+      -> [String]+      -> [[String]]+      -> Eff (ArtifactInterpreter e) [[(String, String)]]+    eachBindingSetT g vars valueSets =+      if all ((== length vars) . length) valueSets+        then return (zip vars <$> valueSets)+        else throwB9Error+               (printf+                  "Error in 'Each' binding during artifact generation in:\n '%s'.\n\nThe variable list\n%s\n has %i entries, but this binding set\n%s\n\nhas a different number of entries!\n"+                  (ppShow g)+                  (ppShow vars)+                  (length vars)+                  (ppShow (head (dropWhile ((== length vars) . length) valueSets))))+    eachBindingSet ::+         (Member ExcB9 e)+      => ArtifactGenerator+      -> [(String, [String])]+      -> Eff (ArtifactInterpreter e) [[(String, String)]]+    eachBindingSet g kvs = do+      checkInput+      return bindingSets+      where+        bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]+        checkInput =+          when+            (1 /= length (nub $ length . snd <$> kvs))+            (throwB9Error+               (printf "Error in 'Each' binding: \n%s\nAll value lists must have the same length!" (ppShow g))) --- | Monad for creating Instance generators.-newtype CGParser a = CGParser-  { runCGParser :: WriterT [InstanceGenerator CGEnv] (ReaderT CGEnv (Either SomeException)) a-  } deriving (MonadThrow, Functor, Applicative, Monad, MonadReader CGEnv, MonadWriter [InstanceGenerator CGEnv])+interpretAssembly ::+     (Member ExcB9 e, Member EnvironmentReader e) => InstanceId -> ArtifactAssembly -> Eff (ArtifactInterpreter e) ()+interpretAssembly (IID iidStrTemplate) assembly = do+  iid@(IID iidStr) <- IID <$> subst iidStrTemplate+  env <- InstanceSources <$> askEnvironment <*> ask+  withSubstitutedStringBindings [(fromString instanceIdKey, fromString iidStr)] (tell [IG iid env assembly]) -data CGEnv = CGEnv-  { agEnv     :: Environment-  , agSources :: [ArtifactSource]+-- | Internal data structure. Only exposed for unit testing.+data InstanceSources = InstanceSources+  { isEnv :: Environment+  , isSources :: [ArtifactSource]   } deriving (Show, Eq)  data InstanceGenerator e =@@ -169,63 +209,57 @@      ArtifactAssembly   deriving (Read, Show, Typeable, Data, Eq) -newtype CGError =-  CGError String-  deriving (Read, Show, Typeable, Data, Eq)--instance Exception CGError--cgError :: String -> CGParser a-cgError msg = throwM (CGError msg)--execCGParser :: CGParser () -> CGEnv -> Either SomeException [InstanceGenerator CGEnv]-execCGParser = runReaderT . execWriterT . runCGParser--execIGEnv :: InstanceGenerator CGEnv -> Either String (InstanceGenerator [SourceGenerator])-execIGEnv (IG iid (CGEnv env sources) assembly) = IG iid <$> sourceGens <*> pure (substAssembly env assembly)-  where-    sourceGens = join <$> mapM (toSourceGen env) sources+toFileInstanceGenerator ::+     Member ExcB9 e => InstanceGenerator InstanceSources -> Eff e (InstanceGenerator [TextFileWriter])+toFileInstanceGenerator (IG iid (InstanceSources env sources) assembly) =+  runEnvironmentReader env $ do+    assembly' <- substAssembly assembly+    sourceGenerators <- join <$> traverse toSourceGen sources+    pure (IG iid sourceGenerators assembly') -substAssembly :: Environment -> ArtifactAssembly -> ArtifactAssembly-substAssembly env = everywhere gsubst+substAssembly ::+     forall e. (Member ExcB9 e, Member EnvironmentReader e)+  => ArtifactAssembly+  -> Eff e ArtifactAssembly+substAssembly = everywhereM gsubst   where-    gsubst :: Data a => a -> a-    gsubst = mkT substAssembly_ `extT` substImageTarget env `extT` substVmScript env-    substAssembly_ (CloudInit ts f) = CloudInit ts (sub f)-    substAssembly_ vm               = vm-    sub = subst env+    gsubst :: Data a => a -> Eff e a+    gsubst = mkM substAssembly_ `extM` substImageTarget `extM` substVmScript+    substAssembly_ (CloudInit ts f) = CloudInit ts <$> subst f+    substAssembly_ vm = pure vm -toSourceGen :: Environment -> ArtifactSource -> Either String [SourceGenerator]-toSourceGen env src =+toSourceGen :: (Member ExcB9 e, Member EnvironmentReader e) => ArtifactSource -> Eff e [TextFileWriter]+toSourceGen src = do+  env <- askEnvironment   case src of     FromFile t (Source conv f) -> do-      t' <- substE env t-      f' <- substE env f-      return [SG env (SGFiles [Source conv f']) KeepPerm t']+      t' <- subst t+      f' <- subst f+      return [MkTextFileWriter env (ExternalFiles [Source conv f']) KeepPermissions t']     FromContent t c -> do-      t' <- substE env t-      return [SG env (SGContent c) KeepPerm t']+      t' <- subst t+      return [MkTextFileWriter env (StaticContent c) KeepPermissions t']     SetPermissions o g a src' -> do-      sgs <- join <$> mapM (toSourceGen env) src'-      mapM (setSGPerm o g a) sgs+      sgs <- join <$> mapM toSourceGen src'+      traverse (setFilePermissionAction o g a) sgs     FromDirectory fromDir src' -> do-      sgs <- join <$> mapM (toSourceGen env) src'-      fromDir' <- substE env fromDir-      return (setSGFromDirectory fromDir' <$> sgs)+      sgs <- join <$> mapM toSourceGen src'+      fromDir' <- subst fromDir+      return (prefixExternalSourcesPaths fromDir' <$> sgs)     IntoDirectory toDir src' -> do-      sgs <- join <$> mapM (toSourceGen env) src'-      toDir' <- substE env toDir-      return (setSGToDirectory toDir' <$> sgs)+      sgs <- join <$> mapM toSourceGen src'+      toDir' <- subst toDir+      return (prefixOutputFilePaths toDir' <$> sgs) -createAssembledArtifacts :: [InstanceGenerator [SourceGenerator]] -> B9 [AssembledArtifact]+createAssembledArtifacts :: IsB9 e => [InstanceGenerator [TextFileWriter]] -> Eff e [AssembledArtifact] createAssembledArtifacts igs = do   buildDir <- getBuildDir   let outDir = buildDir </> "artifact-instances"   ensureDir (outDir ++ "/")   generated <- generateSources outDir `mapM` igs-  createTargets `mapM` generated+  runInstanceGenerator `mapM` generated -generateSources :: FilePath -> InstanceGenerator [SourceGenerator] -> B9 (InstanceGenerator FilePath)+generateSources :: IsB9 e => FilePath -> InstanceGenerator [TextFileWriter] -> Eff e (InstanceGenerator FilePath) generateSources outDir (IG iid sgs assembly) = do   uiid@(IID uiidStr) <- generateUniqueIID iid   dbgL (printf "generating sources for %s" uiidStr)@@ -234,91 +268,89 @@   generateSourceTo instanceDir `mapM_` sgs   return (IG uiid instanceDir assembly) -createTargets :: InstanceGenerator FilePath -> B9 AssembledArtifact-createTargets (IG uiid@(IID uiidStr) instanceDir assembly) = do-  targets <- createTarget uiid instanceDir assembly+-- | Run an+runInstanceGenerator :: IsB9 e => InstanceGenerator FilePath -> Eff e AssembledArtifact+runInstanceGenerator (IG uiid@(IID uiidStr) instanceDir assembly) = do+  targets <- runArtifactAssembly uiid instanceDir assembly   dbgL (printf "assembled artifact %s" uiidStr)   return (AssembledArtifact uiid targets) -generateUniqueIID :: InstanceId -> B9 InstanceId+generateUniqueIID :: IsB9 e => InstanceId -> Eff e InstanceId generateUniqueIID (IID iid) = IID . printf "%s-%s" iid <$> getBuildId -generateSourceTo :: FilePath -> SourceGenerator -> B9 ()-generateSourceTo instanceDir (SG env sgSource p to) = do-  let toAbs = instanceDir </> to-  ensureDir toAbs-  result <--    case sgSource of-      SGFiles froms -> do-        sources <- mapM (sgReadSourceFile env) froms-        return (mconcat sources)-      SGContent c -> renderContentGenerator env (toContentGenerator c)-  traceL (printf "rendered: \n%s\n" (LazyT.unpack (LazyE.decodeUtf8 result)))-  liftIO (Lazy.writeFile toAbs result)-  sgChangePerm toAbs p--sgReadSourceFile :: Environment -> SourceFile -> B9 Lazy.ByteString-sgReadSourceFile env = renderContentGenerator env . readTemplateFile+generateSourceTo :: IsB9 e => FilePath -> TextFileWriter -> Eff e ()+generateSourceTo instanceDir (MkTextFileWriter env sgSource p to) =+  localEnvironment (const env) $ do+    let toAbs = instanceDir </> to+    ensureDir toAbs+    result <-+      case sgSource of+        ExternalFiles froms -> do+          sources <- mapM readTemplateFile froms+          return (mconcat sources)+        StaticContent c -> toContentGenerator c+    traceL (printf "rendered: \n%s\n" (LazyT.unpack (LazyE.decodeUtf8 result)))+    liftIO (Lazy.writeFile toAbs result)+    runFilePermissionAction toAbs p -sgChangePerm :: FilePath -> SGPerm -> B9 ()-sgChangePerm _ KeepPerm = return ()-sgChangePerm f (SGSetPerm (o, g, a)) = cmd (printf "chmod 0%i%i%i '%s'" o g a f)+runFilePermissionAction :: IsB9 e => FilePath -> FilePermissionAction -> Eff e ()+runFilePermissionAction _ KeepPermissions = return ()+runFilePermissionAction f (ChangePermissions (o, g, a)) = cmd (printf "chmod 0%i%i%i '%s'" o g a f)  -- | Internal data type simplifying the rather complex source generation by---   bioling down 'ArtifactSource's to a flat list of uniform 'SourceGenerator's.-data SourceGenerator =-  SG Environment-     SGSource-     SGPerm-     FilePath+--   boiling down 'ArtifactSource's to a flat list of uniform 'TextFileWriter's.+data TextFileWriter =+  MkTextFileWriter Environment+                  TextFileWriterInput+                  FilePermissionAction+                  FilePath   deriving (Show, Eq)  -- | Return the (internal-)output file of the source file that is generated.-sourceGeneratorOutputFile :: SourceGenerator -> FilePath-sourceGeneratorOutputFile (SG _ _ _ f) = f+textFileWriterOutputFile :: TextFileWriter -> FilePath+textFileWriterOutputFile (MkTextFileWriter _ _ _ f) = f -data SGSource-  = SGFiles [SourceFile]-  | SGContent Content+data TextFileWriterInput+  = ExternalFiles [SourceFile]+  | StaticContent Content   deriving (Read, Show, Eq) -data SGPerm-  = SGSetPerm (Int, Int, Int)-  | KeepPerm+data FilePermissionAction+  = ChangePermissions (Int, Int, Int)+  | KeepPermissions   deriving (Read, Show, Typeable, Data, Eq) -sgGetFroms :: SourceGenerator -> [SourceFile]-sgGetFroms (SG _ (SGFiles fs) _ _) = fs-sgGetFroms _                       = []--setSGPerm :: Int -> Int -> Int -> SourceGenerator -> Either String SourceGenerator-setSGPerm o g a (SG env from KeepPerm dest) = Right (SG env from (SGSetPerm (o, g, a)) dest)-setSGPerm o g a sg-  | o < 0 || o > 7 = Left (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))-  | g < 0 || g > 7 = Left (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))-  | a < 0 || a > 7 = Left (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))-  | otherwise = Left (printf "Permission for source already defined:\n %s" (ppShow sg))+setFilePermissionAction :: Member ExcB9 e => Int -> Int -> Int -> TextFileWriter -> Eff e TextFileWriter+setFilePermissionAction o g a (MkTextFileWriter env from KeepPermissions dest) =+  pure (MkTextFileWriter env from (ChangePermissions (o, g, a)) dest)+setFilePermissionAction o g a sg+  | o < 0 || o > 7 = throwB9Error (printf "Bad 'owner' permission %i in \n%s" o (ppShow sg))+  | g < 0 || g > 7 = throwB9Error (printf "Bad 'group' permission %i in \n%s" g (ppShow sg))+  | a < 0 || a > 7 = throwB9Error (printf "Bad 'all' permission %i in \n%s" a (ppShow sg))+  | otherwise = throwB9Error (printf "Permission for source already defined:\n %s" (ppShow sg)) -setSGFromDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGFromDirectory fromDir (SG e (SGFiles fs) p d) = SG e (SGFiles (setSGFrom <$> fs)) p d+prefixExternalSourcesPaths :: FilePath -> TextFileWriter -> TextFileWriter+prefixExternalSourcesPaths fromDir (MkTextFileWriter e (ExternalFiles fs) p d) =+  MkTextFileWriter e (ExternalFiles (prefixExternalSourcePaths <$> fs)) p d   where-    setSGFrom (Source t f) = Source t (fromDir </> f)-setSGFromDirectory _fromDir sg = sg+    prefixExternalSourcePaths (Source t f) = Source t (fromDir </> f)+prefixExternalSourcesPaths _fromDir sg = sg -setSGToDirectory :: FilePath -> SourceGenerator -> SourceGenerator-setSGToDirectory toDir (SG e fs p d) = SG e fs p (toDir </> d)+prefixOutputFilePaths :: FilePath -> TextFileWriter -> TextFileWriter+prefixOutputFilePaths toDir (MkTextFileWriter e fs p d) = MkTextFileWriter e fs p (toDir </> d) --- | Create the actual target, either just a mountpoint, or an ISO or VFAT--- image.-createTarget :: InstanceId -> FilePath -> ArtifactAssembly -> B9 [ArtifactTarget]-createTarget iid instanceDir (VmImages imageTargets vmScript) = do+-- | Create the 'ArtifactTarget' from an 'ArtifactAssembly' in the directory @instanceDir@+--+-- @since 0.5.65+runArtifactAssembly :: IsB9 e => InstanceId -> FilePath -> ArtifactAssembly -> Eff e [ArtifactTarget]+runArtifactAssembly iid instanceDir (VmImages imageTargets vmScript) = do   dbgL (printf "Creating VM-Images in '%s'" instanceDir)   success <- buildWithVm iid imageTargets instanceDir vmScript   let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr       (IID iidStr) = iid   unless success (errorL err_msg >> error err_msg)   return [VmImagesTarget]-createTarget _ instanceDir (CloudInit types outPath) = mapM create_ types+runArtifactAssembly _ instanceDir (CloudInit types outPath) = mapM create_ types   where     create_ CI_DIR = do       let ciDir = outPath

@@ -4,13 +4,21 @@ -} module B9.B9Config   ( B9Config(..)+  , runB9ConfigReader+  , B9ConfigReader+  , getB9Config+  , getExecEnvType+  , getConfig+  , getLogVerbosity+  , getProjectRoot+  , getRemoteRepos+  , isInteractive+  , B9ConfigWriter   , verbosity   , logFile-  , buildDirRoot+  , projectRoot   , keepTempDirs   , execEnvType-  , profileFile-  , envVars   , uniqueBuildDirs   , repositoryCache   , repository@@ -21,14 +29,14 @@   , B9ConfigOverride(..)   , noB9ConfigOverride   , B9ConfigAction()-  , execB9ConfigAction-  , invokeB9-  , askRuntimeConfig-  , localRuntimeConfig+  , runB9ConfigActionWithOverrides+  , runB9ConfigAction+  , localB9Config   , modifyPermanentConfig   , customB9Config   , customB9ConfigPath   , customLibVirtNetwork+  , customEnvironment   , overrideB9ConfigPath   , overrideB9Config   , overrideWorkingDirectory@@ -41,7 +49,6 @@   , writeB9CPDocument   , readB9Config   , parseB9Config-  , appendPositionalArguments   , modifyCPDocument   , b9ConfigToCPDocument   , LogLevel(..)@@ -52,12 +59,13 @@  import B9.B9Config.LibVirtLXC as X import B9.B9Config.Repository as X+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Eff.Writer.Lazy import Control.Exception import Control.Lens as Lens ((&), (.~), (?~), (^.), _Just, makeLenses, over, set) import Control.Monad ((>=>)) import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.Writer import Data.ConfigFile.B9Extras   ( CPDocument   , CPError@@ -74,8 +82,8 @@   ) import Data.Function (on) import Data.Maybe (fromMaybe)-import qualified Data.Semigroup as Sem-import qualified Data.Text.Lazy as LazyT+import Data.Monoid+import Data.Semigroup as Semigroup hiding (Last(..)) import System.Directory import System.IO.B9Extras (SystemPath(..), ensureDir, resolve) import Text.Printf (printf)@@ -97,11 +105,9 @@ data B9Config = B9Config   { _verbosity :: Maybe LogLevel   , _logFile :: Maybe FilePath-  , _buildDirRoot :: Maybe FilePath+  , _projectRoot :: Maybe FilePath   , _keepTempDirs :: Bool   , _execEnvType :: ExecEnvType-  , _profileFile :: Maybe FilePath-  , _envVars :: Environment   , _uniqueBuildDirs :: Bool   , _repositoryCache :: Maybe SystemPath   , _repository :: Maybe String@@ -109,18 +115,16 @@   , _maxLocalSharedImageRevisions :: Maybe Int   , _libVirtLXCConfigs :: Maybe LibVirtLXCConfig   , _remoteRepos :: [RemoteRepo]-  } deriving (Show)+  } deriving (Show, Eq) -instance Sem.Semigroup B9Config where+instance 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'+      , _projectRoot = getLast $ on mappend (Last . _projectRoot) 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')@@ -131,22 +135,86 @@       }  instance Monoid B9Config where-  mappend = (Sem.<>)-  mempty =-    B9Config Nothing Nothing Nothing False LibVirtLXC Nothing mempty True Nothing Nothing False Nothing Nothing []+  mappend = (<>)+  mempty = B9Config Nothing Nothing Nothing False LibVirtLXC True Nothing Nothing False Nothing Nothing [] +-- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'.+--+-- @since 0.5.65+type B9ConfigReader = Reader B9Config++-- | Run a 'B9ConfigReader'.+--+-- @since 0.5.65+runB9ConfigReader :: B9Config -> Eff (B9ConfigReader ': e) a -> Eff e a+runB9ConfigReader = runReader++-- | 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.+--+-- @since 0.5.65+getB9Config :: Member B9ConfigReader e => Eff e B9Config+getB9Config = ask++-- | Run an action with an updated runtime configuration.+--+-- @since 0.5.65+localB9Config :: Member B9ConfigReader e => (B9Config -> B9Config) -> Eff e a -> Eff e a+localB9Config = local++-- | An alias for 'getB9Config'.+--+-- @deprecated+--+-- @since 0.5.65+getConfig :: Member B9ConfigReader e => Eff e B9Config+getConfig = getB9Config++-- | Ask whether @stdin@ of the @B9@ process should be redirected to the+-- external commands executed during the build.+--+-- @since 0.5.65+isInteractive :: Member B9ConfigReader e => Eff e Bool+isInteractive = _interactive <$> getB9Config++-- | Ask for the 'ExecEnvType'.+--+-- @since 0.5.65+getExecEnvType :: Member B9ConfigReader e => Eff e ExecEnvType+getExecEnvType = _execEnvType <$> getB9Config++-- | Ask for the 'RemoteRepo's.+--+-- @since 0.5.65+getRemoteRepos :: Member B9ConfigReader e => Eff e [RemoteRepo]+getRemoteRepos = _remoteRepos <$> getB9Config++-- | Ask for the 'LogLevel'.+--+-- @since 0.5.65+getLogVerbosity :: Member B9ConfigReader e => Eff e (Maybe LogLevel)+getLogVerbosity = _verbosity <$> getB9Config++-- | Ask for the project root directory.+--+-- @since 0.5.65+getProjectRoot :: Member B9ConfigReader e => Eff e FilePath+getProjectRoot = fromMaybe "." . _projectRoot <$> ask+ -- | 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   , _customLibVirtNetwork :: Maybe (Maybe String)+  , _customEnvironment :: Environment   } 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 mempty+noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty mempty  makeLenses ''B9Config @@ -162,7 +230,7 @@  -- | Define the current working directory to be used when building. overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride-overrideWorkingDirectory p = customB9Config . buildDirRoot ?~ p+overrideWorkingDirectory p = customB9Config . projectRoot ?~ p  -- | Overwrite the 'verbosity' settings in the configuration with those given. overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride@@ -173,27 +241,23 @@ overrideKeepBuildDirs = overrideB9Config . Lens.set keepTempDirs  -- | A monad that gives access to the (transient) 'B9Config' to be used at--- _runtime_ with 'askRuntimeConfig' or 'localRuntimeConfig', and that allows+-- _runtime_ with 'getB9Config' or 'localB9Config', 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+-- 'modifyPermanentConfig'. This is the amalgamation of 'B9ConfigWriter'+-- 'B9ConfigReader' and 'IO'.+--+-- @since 0.5.65+type B9ConfigAction a = Eff '[ B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a --- | 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+-- | Accumulate 'B9Config' changes that go back to the config file. See+-- 'B9ConfigAction' and 'modifyPermanentConfig'.+--+-- @since 0.5.65+type B9ConfigWriter = Writer (Semigroup.Endo B9Config)  -- | Add a modification to the permanent configuration file.-modifyPermanentConfig :: Monad m => Endo B9Config -> B9ConfigAction m ()-modifyPermanentConfig f = B9ConfigAction (tell [f])+modifyPermanentConfig :: Member B9ConfigWriter e => Endo B9Config -> Eff e ()+modifyPermanentConfig = tell  -- | Execute a 'B9ConfigAction'. -- It will take a 'B9ConfigOverride' as input. The 'B9Config' in that value is@@ -206,25 +270,28 @@ -- 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+-- See also 'runB9ConfigAction', which does not need the 'B9ConfigOverride' parameter.+--+-- @since 0.5.65+runB9ConfigActionWithOverrides :: B9ConfigAction a -> B9ConfigOverride -> IO a+runB9ConfigActionWithOverrides act cfg = do   let cfgPath = cfg ^. customB9ConfigPath   cp <- openOrCreateB9Config cfgPath   case parseB9Config cp of     Left e -> fail (printf "Internal configuration load error, please report this: %s\n" (show e))-    Right permanentConfig -> do+    Right permanentConfigIn -> do       let runtimeCfg =-            let rc = permanentConfig Sem.<> (cfg ^. customB9Config)+            let rc = permanentConfigIn <> (cfg ^. customB9Config)              in case cfg ^. customLibVirtNetwork of                   Just overridenNetwork -> rc & libVirtLXCConfigs . _Just . networkId .~ overridenNetwork                   Nothing -> rc-      (res, permanentB9ConfigUpdates) <- runWriterT (runReaderT (runB9ConfigAction act) runtimeCfg)-      let cpExtErr = modifyCPDocument cp <$> permanentB9ConfigUpdate-          permanentB9ConfigUpdate =-            if null permanentB9ConfigUpdates+      (res, permanentB9ConfigUpdates) <-+        runLift (runEnvironmentReader (cfg ^. customEnvironment) (runReader runtimeCfg (runMonoidWriter act)))+      let cpExtErr = modifyCPDocument cp <$> permanentB9ConfigUpdateMaybe+          permanentB9ConfigUpdateMaybe =+            if appEndo permanentB9ConfigUpdates permanentConfigIn == permanentConfigIn               then Nothing-              else Just (mconcat permanentB9ConfigUpdates)+              else Just permanentB9ConfigUpdates       cpExt <-         maybe           (return Nothing)@@ -234,9 +301,11 @@       return res  -- | Run a 'B9ConfigAction' using 'noB9ConfigOverride'.--- See 'execB9ConfigAction' for more details.-invokeB9 :: MonadIO m => B9ConfigAction m a -> m a-invokeB9 = flip execB9ConfigAction noB9ConfigOverride+-- See 'runB9ConfigActionWithOverrides' for more details.+--+-- @since 0.5.65+runB9ConfigAction :: B9ConfigAction a -> IO a+runB9ConfigAction = flip runB9ConfigActionWithOverrides noB9ConfigOverride  -- | Open the configuration file that contains the 'B9Config'. -- If the configuration does not exist, write a default configuration file,@@ -268,11 +337,9 @@   B9Config     { _verbosity = Just LogInfo     , _logFile = Nothing-    , _buildDirRoot = Nothing+    , _projectRoot = Nothing     , _keepTempDirs = False     , _execEnvType = LibVirtLXC-    , _profileFile = Nothing-    , _envVars = mempty     , _uniqueBuildDirs = True     , _repository = Nothing     , _repositoryCache = Just defaultRepositoryCache@@ -294,8 +361,8 @@ logFileK :: String logFileK = "log_file" -buildDirRootK :: String-buildDirRootK = "build_dir_root"+projectRootK :: String+projectRootK = "build_dir_root"  keepTempDirsK :: String keepTempDirsK = "keep_temp_dirs"@@ -303,12 +370,6 @@ execEnvTypeK :: String execEnvTypeK = "exec_env" -profileFileK :: String-profileFileK = "profile_file"--envVarsK :: String-envVarsK = "environment_vars"- uniqueBuildDirsK :: String uniqueBuildDirsK = "unique_build_dirs" @@ -337,16 +398,14 @@   cp1 <- addSectionCP emptyCP cfgFileSection   cp2 <- setShowCP cp1 cfgFileSection verbosityK (_verbosity c)   cp3 <- setShowCP cp2 cfgFileSection logFileK (_logFile c)-  cp4 <- setShowCP cp3 cfgFileSection buildDirRootK (_buildDirRoot c)+  cp4 <- setShowCP cp3 cfgFileSection projectRootK (_projectRoot c)   cp5 <- setShowCP cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)   cp6 <- setShowCP cp5 cfgFileSection execEnvTypeK (_execEnvType c)-  cp7 <- setShowCP cp6 cfgFileSection profileFileK (_profileFile c)-  cp8 <- setShowCP cp7 cfgFileSection envVarsK (_envVars c)-  cp9 <- setShowCP cp8 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)-  cpA <- setShowCP cp9 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c)-  cpB <- setShowCP cpA cfgFileSection repositoryCacheK (_repositoryCache c)-  cpC <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cpB-  cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpC+  cp7 <- setShowCP cp6 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)+  cp8 <- setShowCP cp7 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c)+  cp9 <- setShowCP cp8 cfgFileSection repositoryCacheK (_repositoryCache c)+  cpA <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cp9+  cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpA   setShowCP cpFinal cfgFileSection repositoryK (_repository c)  readB9Config :: MonadIO m => Maybe SystemPath -> m CPDocument@@ -356,25 +415,11 @@ parseB9Config cp =   let getr :: (CPGet a) => CPOptionSpec -> Either CPError a       getr = readCP cp cfgFileSection-      getB9Config =-        B9Config <$> getr verbosityK <*> getr logFileK <*> getr buildDirRootK <*> getr keepTempDirsK <*>-        getr execEnvTypeK <*>-        getr profileFileK <*>-        (fromStringPairs <$> getr envVarsK)-         <*>-        getr uniqueBuildDirsK <*>-        getr repositoryCacheK <*>-        getr repositoryK <*>-        pure False <*>-        pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK)) <*>-        pure (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 = insertPositionalArguments (LazyT.pack <$> extraPositional)+   in B9Config <$> getr verbosityK <*> getr logFileK <*> getr projectRootK <*> getr keepTempDirsK <*> getr execEnvTypeK <*>+      getr uniqueBuildDirsK <*>+      getr repositoryCacheK <*>+      getr repositoryK <*>+      pure False <*>+      pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK)) <*>+      pure (either (const Nothing) Just (parseLibVirtLXCConfig cp)) <*>+      parseRemoteRepos cp

@@ -20,7 +20,7 @@   , _networkId :: Maybe String   , guestCapabilities :: [LXCGuestCapability]   , guestRamSize :: RamSize-  } deriving (Read, Show)+  } deriving (Read, Show, Eq)  -- | Available linux capabilities for lxc containers. This maps directly to the -- capabilities defined in 'man 7 capabilities'.@@ -63,7 +63,7 @@   | CAP_SYS_TTY_CONFIG   | CAP_SYSLOG   | CAP_WAKE_ALARM-  deriving (Read, Show)+  deriving (Read, Show, Eq)  makeLenses ''LibVirtLXCConfig 

@@ -20,19 +20,19 @@                              SshPrivKey                              SshRemoteHost                              SshRemoteUser-  deriving (Read, Show, Typeable, Data)+  deriving (Read, Show, Typeable, Data, Eq)  remoteRepoRepoId :: RemoteRepo -> String remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId  newtype SshPrivKey = SshPrivKey FilePath-  deriving (Read, Show, Typeable, Data)+  deriving (Read, Show, Typeable, Data, Eq)  newtype SshRemoteHost = SshRemoteHost (String,Int)-  deriving (Read, Show, Typeable, Data)+  deriving (Read, Show, Typeable, Data, Eq)  newtype SshRemoteUser = SshRemoteUser String-  deriving (Read, Show, Typeable, Data)+  deriving (Read, Show, Typeable, Data, Eq)   -- | Persist a repo to a configuration file.

@@ -0,0 +1,95 @@+-- | Error handling in B9 via extensible effects.+-- B9 wraps errors in `SomeException`.+--+-- @since 0.5.64+module B9.B9Error+  ( throwSomeException+  , throwSomeException_+  , throwB9Error+  , throwB9Error_+  , errorOnException+  , ExcB9+  , runExcB9+  , B9Error(MkB9Error)+  , fromB9Error+  , catchB9Error+  , catchB9ErrorAsEither+  )+where++import           Control.Exception              ( toException+                                                , SomeException+                                                , Exception+                                                , displayException+                                                )+import           Control.Eff                   as Eff+import           Control.Eff.Exception         as Eff+import           Control.Monad+import           Data.String                    ( IsString(..) )++-- | The exception effect used in most places in B9.+--  This is `Exc` specialized with `SomeException`.+--+-- @since 0.5.64+type ExcB9 = Exc SomeException++-- | This is a simple runtime exception to indicate that B9 code encountered+-- some exceptional event.+--+-- @since 0.5.64+newtype B9Error = MkB9Error { fromB9Error :: String }+  deriving (Show, IsString)++instance Exception B9Error++-- | Run an `ExcB9`.+--+-- @since 0.5.64+runExcB9 :: Eff (ExcB9 ': e) a -> Eff e (Either SomeException a)+runExcB9 = runError++-- | Run an `ExcB9` and rethrow the exception with `error`.+--+-- @since 0.5.64+errorOnException :: Eff (ExcB9 ': e) a -> Eff e a+errorOnException = runError >=> either (error . displayException) pure++-- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects+--+-- @since 0.5.64+throwSomeException :: (Member ExcB9 e, Exception x) => x -> Eff e a+throwSomeException = throwError . toException++-- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects+--+-- @since 0.5.64+throwSomeException_ :: (Member ExcB9 e, Exception x) => x -> Eff e ()+throwSomeException_ = throwError_ . toException+++-- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects+--+-- @since 0.5.64+throwB9Error :: Member ExcB9 e => String -> Eff e a+throwB9Error = throwSomeException . MkB9Error++-- | 'SomeException' wrapped into 'Exc'ecption 'Eff'ects+--+-- @since 0.5.64+throwB9Error_ :: Member ExcB9 e => String -> Eff e ()+throwB9Error_ = throwSomeException_ . MkB9Error++-- | Catch exceptions.+--+-- @since 0.5.64+catchB9Error+  :: Member ExcB9 e => Eff e a -> (SomeException -> Eff e a) -> Eff e a+catchB9Error = catchError+++-- | Catch exceptions and return them via 'Either'.+--+-- @since 0.5.64+catchB9ErrorAsEither+  :: Member ExcB9 e => Eff e a -> Eff e (Either SomeException a)+catchB9ErrorAsEither x = catchB9Error (Right <$> x) (pure . Left)

@@ -0,0 +1,79 @@+-- | This modules contains support for external command execution.+--+-- @since 0.5.65+module B9.B9Exec+  ( cmd+  ) where++import B9.B9Config+import B9.B9Logging+import Control.Concurrent.Async (Concurrently(..))+import Control.Eff+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control (embed_)+import qualified Data.ByteString.Char8 as Strict+import Data.Conduit ((.|), runConduit)+import qualified Data.Conduit.List as CL+import Data.Conduit.Process+import Data.Functor ()+import System.Exit+import Text.Printf++-- | Execute the given shell command.+--+-- If 'isInteractive' is true, the standard-in will be passed to the external command,+-- and all output of the program will be directed to standard-out.+--+-- The command and the output is either logged to the logfile with 'traceL' or 'errorL' or+-- written to stdout.+--+-- If the command exists with non-zero exit code, the current process exists with the same+-- exit code.+--+-- @since 0.5.65+cmd :: CommandIO e => String -> Eff e ()+cmd str = do+  inheritStdIn <- isInteractive+  if inheritStdIn+    then interactiveCmd str+    else nonInteractiveCmd str++interactiveCmd ::+     forall e. CommandIO e+  => String+  -> Eff e ()+interactiveCmd str = void (cmdWithStdIn True str :: Eff e Inherited)++nonInteractiveCmd ::+     forall e. CommandIO e+  => String+  -> Eff e ()+-- TODO if we use 'ClosedStream' we get an error from 'virsh console'+-- complaining about a missing controlling tty. Original source line:+-- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream)+nonInteractiveCmd str = void (cmdWithStdIn False str :: Eff e Inherited)++cmdWithStdIn :: (CommandIO e, InputSource stdin) => Bool -> String -> Eff e stdin+cmdWithStdIn toStdOut cmdStr = do+  traceL $ "COMMAND: " ++ cmdStr+  traceLIO <- embed_ (traceL . Strict.unpack)+  errorLIO <- embed_ (errorL . Strict.unpack)+  let errorLC = CL.mapM_ (liftIO . errorLIO)+  let traceLC =+        if toStdOut+          then CL.mapM_ Strict.putStr+          else CL.mapM_ (liftIO . traceLIO)+  (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)+  e <-+    liftIO $+    runConcurrently $+    Concurrently (runConduit (cpOut .| traceLC)) *> Concurrently (runConduit (cpErr .| errorLC)) *>+    Concurrently (waitForStreamingProcess cph)+  checkExitCode e+  return cpIn+  where+    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

@@ -0,0 +1,105 @@+-- | This modules contains support for logging.+--+-- @since 0.5.65+module B9.B9Logging+  ( Logger(..)+  , CommandIO+  , LoggerReader+  , withLogger+  , b9Log+  , traceL+  , dbgL+  , infoL+  , errorL+  , errorExitL+  ) where++import B9.B9Config+import B9.B9Error+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM)+import Data.Maybe+import Data.Time.Clock+import Data.Time.Format+import qualified System.IO as SysIO+import Text.Printf++-- | The logger to write log messages to.+--+-- @since 0.5.65+newtype Logger = MkLogger+  { logFileHandle :: Maybe SysIO.Handle+  }++-- | Effect that reads a 'Logger'.+--+-- @since 0.5.65+type LoggerReader = Reader Logger++-- | Lookup the selected 'getLogVerbosity' and '_logFile' from the 'B9Config'+-- and open it.+--+-- Then run the given action; if the action crashes, the log file will be closed.+--+-- @since 0.5.65+withLogger ::+     (MonadBaseControl IO (Eff e), MonadIO (Eff e), Member B9ConfigReader e) => Eff (LoggerReader ': e) a -> Eff e a+withLogger action = do+  lf <- _logFile <$> getB9Config+  effState <-+    liftBaseWith $ \runInIO ->+      let fInIO = runInIO . flip runReader action . MkLogger+       in maybe (fInIO Nothing) (\logf -> SysIO.withFile logf SysIO.AppendMode (fInIO . Just)) lf+  restoreM effState++-- | Convenience type alias for 'Eff'ects that have a 'B9Config', a 'Logger', 'MonadIO' and 'MonadBaseControl'.+--+-- @since 0.5.65+type CommandIO e = (MonadBaseControl IO (Eff e), MonadIO (Eff e), Member LoggerReader e, Member B9ConfigReader e)++traceL :: CommandIO e => String -> Eff e ()+traceL = b9Log LogTrace++dbgL :: CommandIO e => String -> Eff e ()+dbgL = b9Log LogDebug++infoL :: CommandIO e => String -> Eff e ()+infoL = b9Log LogInfo++errorL :: CommandIO e => String -> Eff e ()+errorL = b9Log LogError++errorExitL :: (CommandIO e, Member ExcB9 e) => String -> Eff e a+errorExitL e = b9Log LogError e >> throwB9Error e++b9Log :: CommandIO e => LogLevel -> String -> Eff e ()+b9Log level msg = do+  lv <- getLogVerbosity+  lfh <- logFileHandle <$> ask+  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)++formatLogMsg :: LogLevel -> String -> IO String+formatLogMsg l msg = do+  u <- getCurrentTime+  let time = formatTime defaultTimeLocale "%H:%M:%S" u+  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 "

@@ -1,286 +1,52 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-| Definition of the B9 monad. It encapsulates logging, very basic command-execution profiling, a reader for the "B9.B9Config" and access to the-current build id, the current build directory and the artifact to build.--This module is used by the _effectful_ functions in this library.--} module B9.B9Monad-  ( B9-  , run-  , traceL-  , dbgL-  , infoL-  , errorL-  , errorExitL-  , getConfig-  , getBuildId-  , getBuildDate-  , getBuildDir-  , getExecEnvType-  , getSelectedRemoteRepo-  , getRemoteRepos-  , getRepoCache-  , cmd+  ( runB9+  , B9+  , B9Eff+  , IsB9   ) where -import           B9.B9Config-import           B9.Environment-import           B9.Repository-import           Control.Applicative-import           Control.Concurrent.Async (Concurrently (..))-import           Control.Exception        (bracket)-import           Control.Lens             ((%~), (&), (.~), (?~), (^.))-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.State-import qualified Data.ByteString.Char8    as Strict-import           Data.Conduit             (runConduit, (.|))-import qualified Data.Conduit.List        as CL-import           Data.Conduit.Process-import           Data.Foldable-import           Data.Functor             ()-import           Data.Hashable-import           Data.Maybe-import           Data.Time.Clock-import           Data.Time.Format-import           Data.Word                (Word32)-import           System.Directory-import           System.Exit-import           System.FilePath-import qualified System.IO                as SysIO-import           System.Random            (randomIO)-import           Text.Printf--data BuildState = BuildState-  { bsBuildId            :: String-  , bsBuildDate          :: String-  , bsCfg                :: B9Config-  , bsBuildDir           :: FilePath-  , bsLogFileHandle      :: Maybe SysIO.Handle-  , bsSelectedRemoteRepo :: Maybe RemoteRepo-  , bsRepoCache          :: RepoCache-  , bsProf               :: [ProfilingEntry]-  , bsStartTime          :: UTCTime-  , bsInheritStdIn       :: Bool-  }--data ProfilingEntry-  = IoActionDuration NominalDiffTime-  | LogEvent LogLevel-             String-  deriving (Eq, Show)--run :: MonadIO m => B9 a -> B9ConfigAction m a-run action = do-  cfg <- askRuntimeConfig-  liftIO $ do-    buildId <- liftIO $ generateBuildId cfg-    now <- liftIO getCurrentTime-    liftIO $ withBuildDir cfg buildId (withLogFile cfg . runImpl cfg buildId now)-  where-    resolveBuildDirRoot cfg =-      case _buildDirRoot cfg of-        Nothing -> getCurrentDirectory >>= canonicalizePath-        Just root' -> do-          createDirectoryIfMissing True root'-          canonicalizePath root'-    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)-    runImpl cfg buildId now buildDir logFileHandle = do-      repoCache <- initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))-      let buildDate = formatTime undefined "%F-%T" now-      remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)-      buildDirRootAbs <- resolveBuildDirRoot cfg-      let finalCfg =-            cfg & remoteRepos .~ remoteRepos' & (buildDirRoot ?~ buildDirRootAbs) & envVars %~ fromJust .-            addStringBinding ("buildDirRoot", buildDirRootAbs)-          ctx =-            BuildState-              buildId-              buildDate-              finalCfg-              buildDir-              logFileHandle-              selectedRemoteRepo-              repoCache-              []-              now-              (_interactive finalCfg)-          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-      when (isJust (_profileFile cfg)) $-        writeFile (fromJust (_profileFile cfg)) (unlines $ show <$> reverse (bsProf ctxOut))-      return r-            -- Check repositories-    createBuildDir cfg buildId = do-      let subDir = "BUILD-" ++ buildId-      buildDir <- resolveBuildDir subDir-      createDirectoryIfMissing True buildDir-      canonicalizePath buildDir-      where-        resolveBuildDir f = do-          root <- resolveBuildDirRoot cfg-          return $ root </> f-    removeBuildDir cfg buildDir =-      when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ removeDirectoryRecursive buildDir-    generateBuildId cfg =-      let cfgHash = hash (show cfg)-       in if _uniqueBuildDirs cfg-            then do-              salt <- randomIO :: IO Word32-              return (printf "%08X-%08X" cfgHash salt)-            else return (printf "%08X" cfgHash)-    wrappedAction = do-      b9cfg <- getConfig-      traverse_ (traceL . printf "Root Build Directory: %s") (b9cfg ^. buildDirRoot)-      startTime <- gets bsStartTime-      r <- action-      now <- liftIO getCurrentTime-      let duration = show (now `diffUTCTime` startTime)-      infoL (printf "DURATION: %s" duration)-      return r---- Run the action build action-getBuildId :: B9 String-getBuildId = gets bsBuildId--getBuildDate :: B9 String-getBuildDate = gets bsBuildDate--getBuildDir :: B9 FilePath-getBuildDir = gets bsBuildDir--getConfig :: B9 B9Config-getConfig = gets bsCfg--getExecEnvType :: B9 ExecEnvType-getExecEnvType = gets (_execEnvType . bsCfg)--getSelectedRemoteRepo :: B9 (Maybe RemoteRepo)-getSelectedRemoteRepo = gets bsSelectedRemoteRepo--getRemoteRepos :: B9 [RemoteRepo]-getRemoteRepos = gets (_remoteRepos . bsCfg)--getRepoCache :: B9 RepoCache-getRepoCache = gets bsRepoCache+import B9.B9Config+import B9.B9Error+import B9.B9Logging+import B9.BuildInfo+import B9.Environment+import B9.Repository+import Control.Eff+import Data.Functor () --- getDownloader :: B9 Downloader--- getDownloader = gets bsDownloader+-- | Definition of the B9 monad. See 'B9Eff'. ----- -- | Configuration for a tool that retreives arbitrary URL and returns them to--- -- @stdout@.--- data Downloader =---   Downloader {downloaderCmd :: FilePath---              ,downloaderArgsBeforeUrl :: [String]---              ,downloaderUrlArgPrintfFormatString :: [String]---              ,downloaderArgsAfterUrl :: [String]}---   deriving (Read,Show,Eq,Ord,Typeable,Generic)+-- This module is used by the _effectful_ functions in this library. ----- readContentFromUrl :: String -> B9 Strict.ByteString--- readContentFromUrl url = do---   return expression-cmd :: String -> B9 ()-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)--nonInteractiveCmd :: String -> B9 ()--- TODO if we use 'ClosedStream' we get an error from 'virsh console'--- complaining about a missing controlling tty. Original source line:--- nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 ClosedStream)-nonInteractiveCmd str = void (cmdWithStdIn False str :: B9 Inherited)--cmdWithStdIn :: (InputSource stdin) => Bool -> String -> B9 stdin-cmdWithStdIn toStdOut cmdStr = do-  traceL $ "COMMAND: " ++ cmdStr-  cmdLogger <- getCmdLogger-  let outPipe =-        if toStdOut-          then CL.mapM_ Strict.putStr-          else cmdLogger LogTrace-  (cpIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr)-  e <--    liftIO $ runConcurrently $ Concurrently (runConduit (cpOut .| outPipe)) *>-    Concurrently (runConduit (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 . Strict.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--dbgL :: String -> B9 ()-dbgL = b9Log LogDebug--infoL :: String -> B9 ()-infoL = b9Log LogInfo--errorL :: String -> B9 ()-errorL = b9Log LogError--errorExitL :: String -> B9 a-errorExitL e = b9Log LogError e >> fail e--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--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+-- @since 0.5.65+type B9 a = Eff B9Eff a -printLevel :: LogLevel -> String-printLevel l =-  case l of-    LogNothing -> "NOTHING"-    LogError   -> " ERROR "-    LogInfo    -> " INFO  "-    LogDebug   -> " DEBUG "-    LogTrace   -> " TRACE "+-- | Definition of the B9 effect list. It encapsulates logging,+-- a reader for the "B9.B9Config" and access to the+-- current build id, the current build directory and the artifact to build.+--+-- This monad is used by the _effectful_ functions in this library.+--+-- @since 0.5.65+type B9Eff+   = '[ SelectedRemoteRepoReader, RepoCacheReader, BuildInfoReader, LoggerReader, B9ConfigReader, EnvironmentReader, ExcB9, Lift IO] -newtype B9 a = B9-  { runB9 :: StateT BuildState IO a-  } deriving (Functor, Applicative, Monad, MonadState BuildState, Alternative)+-- | A constraint that contains all effects of 'B9Eff'+--+-- @since 0.5.65+type IsB9 e = (Lifted IO e, CommandIO e, B9Eff <:: e) -instance MonadIO B9 where-  liftIO m = do-    start <- B9 $ liftIO getCurrentTime-    res <- B9 $ liftIO m-    stop <- B9 $ liftIO getCurrentTime-    let durMS = IoActionDuration (stop `diffUTCTime` start)-    modify $ \ctx -> ctx {bsProf = durMS : bsProf ctx}-    return res+-- | Execute a 'B9' effect and return an action that needs+-- the 'B9Config'.+--+-- @since 0.5.65+runB9 :: B9 a -> B9ConfigAction a+runB9 action = do+  cfg <- getB9Config+  env <- askEnvironment+  lift+    (runLift .+     errorOnException .+     runEnvironmentReader env .+     runB9ConfigReader cfg . withLogger . withBuildInfo . withRemoteRepos . withSelectedRemoteRepo $+     action)

@@ -0,0 +1,128 @@+-- | Provide information about the current build.+--+-- This module provides build meta information like+-- build directory, build-id and build-time.+--+-- @since 0.5.65+module B9.BuildInfo+  ( getBuildId+  , getBuildDate+  , getBuildDir+  , getExecEnvType+  , withBuildInfo+  , BuildInfoReader+  ) where++import B9.B9Config+import B9.B9Error+import B9.B9Logging+import B9.Environment+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Exception (bracket)+import Control.Lens ((?~))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control (MonadBaseControl, control)+import Data.Functor ()+import Data.Hashable+import Data.Time.Clock+import Data.Time.Format+import System.Directory+import System.FilePath+import Text.Printf++-- | Build meta information.+--+-- @since 0.5.65+data BuildInfo = BuildInfo+  { bsBuildId :: String+  , bsBuildDate :: String+  , bsBuildDir :: FilePath+  , bsStartTime :: UTCTime+  } deriving (Eq, Show)++-- | Type alias for a 'BuildInfo' 'Reader'+--+-- @since 0.5.65+type BuildInfoReader = Reader BuildInfo++-- | Create the build directories, generate (hash) the build-id and execute the given action.+--+-- Export the @projectRoot@ 'Environment' variable.+--+-- Unless '_keepTempDirs' is @True@ clean up the build directories after the actions+-- returns - even if the action throws a runtime exception.+--+-- @since 0.5.65+withBuildInfo ::+     ( Lifted IO e+     , MonadBaseControl IO (Eff e)+     , Member B9ConfigReader e+     , Member ExcB9 e+     , Member EnvironmentReader e+     , Member LoggerReader e+     )+  => Eff (BuildInfoReader ': e) a+  -> Eff e a+withBuildInfo action =+  withRootDir $ do+    now <- lift getCurrentTime+    let buildDate = formatTime undefined "%F-%T" now+    buildId <- generateBuildId buildDate+    withBuildDir buildId (runImpl buildId buildDate now)+  where+    withRootDir f = do+      mRoot <- _projectRoot <$> getB9Config+      root <-+        lift $+        case mRoot of+          Nothing -> getCurrentDirectory >>= canonicalizePath+          Just rootIn -> do+            createDirectoryIfMissing True rootIn+            canonicalizePath rootIn+      localB9Config (projectRoot ?~ root) (addLocalStringBinding ("projectRoot", root) f)+    generateBuildId buildDate = do+      unqiueBuildDir <- _uniqueBuildDirs <$> getB9Config+      cfgHash <- hash . show <$> getB9Config+      if unqiueBuildDir+        then return (printf "%08X-%08X" cfgHash (hash buildDate))+        else return (printf "%08X" cfgHash)+    withBuildDir buildId f = do+      root <- _projectRoot <$> getB9Config+      cfg <- getB9Config+      control $ \runInIO -> bracket (createBuildDir root) (removeBuildDir cfg) (runInIO . f)+      where+        createBuildDir root = do+          let buildDir =+                case root of+                  Just r -> r </> "BUILD-" ++ buildId+                  Nothing -> "BUILD-" ++ buildId+          createDirectoryIfMissing True buildDir+          canonicalizePath buildDir+        removeBuildDir cfg buildDir =+          when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ removeDirectoryRecursive buildDir+    runImpl buildId buildDate startTime buildDir =+      let ctx = BuildInfo buildId buildDate buildDir startTime+       in runReader ctx wrappedAction+      where+        wrappedAction = do+          rootD <- getProjectRoot+          traceL (printf "Project Root Directory: %s" rootD)+          buildD <- getBuildDir+          traceL (printf "Build Directory:        %s" buildD)+          r <- action+          tsAfter <- liftIO getCurrentTime+          let duration = show (tsAfter `diffUTCTime` startTime)+          infoL (printf "DURATION: %s" duration)+          return r++-- Run the action build action+getBuildId :: Member BuildInfoReader e => Eff e String+getBuildId = bsBuildId <$> ask++getBuildDate :: Member BuildInfoReader e => Eff e String+getBuildDate = bsBuildDate <$> ask++getBuildDir :: Member BuildInfoReader e => Eff e FilePath+getBuildDir = bsBuildDir <$> ask

@@ -22,115 +22,135 @@   , getSelectedRepos   , pullRemoteRepos   , pullLatestImage-  ) where+  )+where -import B9.B9Config-import B9.B9Monad-import B9.Artifact.Content.StringTemplate-import B9.DiskImages-import qualified B9.PartitionTable as P-import B9.Repository-import B9.RepositoryIO-import Control.Exception-import Control.Lens ((^.))-import Control.Monad-import Control.Monad.IO.Class-import Data.Data-import Data.Function-import Data.Generics.Aliases-import Data.Generics.Schemes-import Data.List-import Data.Maybe-import System.Directory-import System.FilePath-import System.IO.B9Extras (consult, ensureDir, prettyPrintToFile)-import System.IO.Error (isDoesNotExistError)-import Text.Printf (printf)-import Text.Show.Pretty (ppShow)+import           B9.B9Config+import           B9.BuildInfo+import           B9.B9Exec+import           B9.B9Logging+import           B9.B9Error+import           B9.B9Monad+import           B9.Artifact.Content.StringTemplate+import           B9.DiskImages+import           B9.Environment+import qualified B9.PartitionTable             as P+import           B9.Repository+import           B9.RepositoryIO+import           Control.Eff+import           Control.Exception+import           Control.Lens                   ( (^.) )+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Function+import           Data.Generics.Aliases+import           Data.Generics.Schemes+import           Data.List+import           Data.Maybe+import           System.Directory+import           System.FilePath+import           System.IO.B9Extras             ( consult+                                                , ensureDir+                                                , prettyPrintToFile+                                                )+import           System.IO.Error                ( isDoesNotExistError )+import           Text.Printf                    ( printf )+import           Text.Show.Pretty               ( ppShow )  -- -- | Convert relative file paths of images, sources and mounted host directories--- -- to absolute paths relative to '_buildDirRoot'.+-- -- to absolute paths relative to '_projectRoot'. -- makeImagePathsAbsoluteToBuildDirRoot :: ImageTarget -> B9 ImageTarget -- makeImagePathsAbsoluteToBuildDirRoot img =---   getConfig >>= maybe (return img) (return . go) . _buildDirRoot+--   getConfig >>= maybe (return img) (return . go) . _projectRoot --   where --     go rootDir = everywhere mkAbs img --       where mkAbs = mkT -- | Replace $... variables inside an 'ImageTarget'-substImageTarget :: Environment -> ImageTarget -> ImageTarget-substImageTarget env = everywhere gsubst-  where-    gsubst :: Data a => a -> a-    gsubst = mkT substMountPoint `extT` substImage `extT` substImageSource `extT` substDiskTarget-    substMountPoint NotMounted = NotMounted-    substMountPoint (MountPoint x) = MountPoint (sub x)-    substImage (Image fp t fs) = Image (sub fp) t fs-    substImageSource (From n s) = From (sub n) s-    substImageSource (EmptyImage l f t s) = EmptyImage (sub l) f t s-    substImageSource s = s-    substDiskTarget (Share n t s) = Share (sub n) t s-    substDiskTarget (LiveInstallerImage name outDir resize) = LiveInstallerImage (sub name) (sub outDir) resize-    substDiskTarget s = s-    sub = subst env+substImageTarget+  :: forall e+   . (Member EnvironmentReader e, Member ExcB9 e)+  => ImageTarget+  -> Eff e ImageTarget+substImageTarget = everywhereM gsubst+ where+  gsubst :: GenericM (Eff e)+  gsubst =+    mkM substMountPoint+      `extM` substImage+      `extM` substImageSource+      `extM` substDiskTarget+  substMountPoint NotMounted     = pure NotMounted+  substMountPoint (MountPoint x) = MountPoint <$> subst x+  substImage (Image fp t fs) = Image <$> subst fp <*> pure t <*> pure fs+  substImageSource (From n s) = From <$> subst n <*> pure s+  substImageSource (EmptyImage l f t s) =+    EmptyImage <$> subst l <*> pure f <*> pure t <*> pure s+  substImageSource s = pure s+  substDiskTarget (Share n t s) = Share <$> subst n <*> pure t <*> pure s+  substDiskTarget (LiveInstallerImage name outDir resize) =+    LiveInstallerImage <$> subst name <*> subst outDir <*> pure resize+  substDiskTarget s = pure s  -- | Resolve an ImageSource to an 'Image'. The ImageSource might -- not exist, as is the case for 'EmptyImage'.-resolveImageSource :: ImageSource -> B9 Image-resolveImageSource src =-  case src of-    (EmptyImage fsLabel fsType imgType _size) ->-      let img = Image fsLabel imgType fsType-       in return (changeImageFormat imgType img)-    (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg-    (CopyOnWrite backingImg) -> ensureAbsoluteImageDirExists backingImg-    (From name _resize) ->-      getLatestImageByName (SharedImageName name) >>=-      maybe (errorExitL (printf "Nothing found for %s." (show (SharedImageName name)))) ensureAbsoluteImageDirExists+resolveImageSource :: IsB9 e => ImageSource -> Eff e Image+resolveImageSource src = case src of+  (EmptyImage fsLabel fsType imgType _size) ->+    let img = Image fsLabel imgType fsType+    in  return (changeImageFormat imgType img)+  (SourceImage srcImg _part _resize) -> ensureAbsoluteImageDirExists srcImg+  (CopyOnWrite backingImg          ) -> ensureAbsoluteImageDirExists backingImg+  (From name _resize) ->+    getLatestImageByName (SharedImageName name)+      >>= maybe+            (errorExitL+              (printf "Nothing found for %s." (show (SharedImageName name)))+            )+            ensureAbsoluteImageDirExists  -- | Return all valid image types sorted by preference.-preferredDestImageTypes :: ImageSource -> B9 [ImageType]-preferredDestImageTypes src =-  case src of-    (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]-    (EmptyImage _label NoFileSystem fmt _size) -> return (nub [fmt, Raw, QCow2, Vmdk])-    (EmptyImage _label _fs _fmt _size) -> return [Raw]-    (SourceImage _img (Partition _) _resize) -> return [Raw]-    (SourceImage (Image _file fmt _fs) _pt resize) ->-      return (nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize)-    (From name resize) ->-      getLatestImageByName (SharedImageName name) >>=-      maybe-        (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))-        (\sharedImg -> preferredDestImageTypes (SourceImage sharedImg NoPT resize))+preferredDestImageTypes :: IsB9 e => ImageSource -> Eff e [ImageType]+preferredDestImageTypes src = case src of+  (CopyOnWrite (Image _file fmt _fs)) -> return [fmt]+  (EmptyImage _label NoFileSystem fmt _size) ->+    return (nub [fmt, Raw, QCow2, Vmdk])+  (EmptyImage _label _fs _fmt _size                       ) -> return [Raw]+  (SourceImage _img                  (Partition _) _resize) -> return [Raw]+  (SourceImage (Image _file fmt _fs) _pt           resize ) -> return+    (nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize)+  (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe+    (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+    (\sharedImg -> preferredDestImageTypes (SourceImage sharedImg NoPT resize))  -- | Return all supported source 'ImageType's compatible to a 'ImageDestinaion' -- in the preferred order. preferredSourceImageTypes :: ImageDestination -> [ImageType]-preferredSourceImageTypes dest =-  case dest of-    (Share _ fmt resize) -> nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize-    (LocalFile (Image _ fmt _) resize) -> nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize-    Transient -> [Raw, QCow2, Vmdk]-    (LiveInstallerImage _name _repo _imgResize) -> [Raw]+preferredSourceImageTypes dest = case dest of+  (Share _ fmt resize) ->+    nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+  (LocalFile (Image _ fmt _) resize) ->+    nub [fmt, Raw, QCow2, Vmdk] `intersect` allowedImageTypesForResize resize+  Transient -> [Raw, QCow2, Vmdk]+  (LiveInstallerImage _name _repo _imgResize) -> [Raw]  allowedImageTypesForResize :: ImageResize -> [ImageType]-allowedImageTypesForResize r =-  case r of-    Resize _ -> [Raw]-    ShrinkToMinimum -> [Raw]-    _ -> [Raw, QCow2, Vmdk]+allowedImageTypesForResize r = case r of+  Resize _        -> [Raw]+  ShrinkToMinimum -> [Raw]+  _               -> [Raw, QCow2, Vmdk]  -- | Create the parent directories for the file that contains the 'Image'.--- If the path to the image file is relative, prepend '_buildDirRoot' from+-- If the path to the image file is relative, prepend '_projectRoot' from -- the 'B9Config'.-ensureAbsoluteImageDirExists :: Image -> B9 Image+ensureAbsoluteImageDirExists :: IsB9 e => Image -> Eff e Image ensureAbsoluteImageDirExists img@(Image path _ _) = do   b9cfg <- getConfig   let dir =         let dirRel = takeDirectory path-         in if isRelative dirRel-              then let prefix = fromMaybe "." (b9cfg ^. buildDirRoot)-                    in prefix </> dirRel+        in  if isRelative dirRel+              then+                let prefix = fromMaybe "." (b9cfg ^. projectRoot)+                in  prefix </> dirRel               else dirRel   liftIO $ do     createDirectoryIfMissing True dir@@ -140,95 +160,113 @@ -- | Create an image from an image source. The destination image must have a -- compatible image type and filesystem. The directory of the image MUST be -- present and the image file itself MUST NOT alredy exist.-materializeImageSource :: ImageSource -> Image -> B9 ()-materializeImageSource src dest =-  case src of-    (EmptyImage fsLabel fsType _imgType size) ->-      let (Image _ imgType _) = dest-       in createEmptyImage fsLabel fsType imgType size dest-    (SourceImage srcImg part resize) -> createImageFromImage srcImg part resize dest-    (CopyOnWrite backingImg) -> createCOWImage backingImg dest-    (From name resize) ->-      getLatestImageByName (SharedImageName name) >>=-      maybe-        (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))-        (\sharedImg -> materializeImageSource (SourceImage sharedImg NoPT resize) dest)+materializeImageSource :: IsB9 e => ImageSource -> Image -> Eff e ()+materializeImageSource src dest = case src of+  (EmptyImage fsLabel fsType _imgType size) ->+    let (Image _ imgType _) = dest+    in  createEmptyImage fsLabel fsType imgType size dest+  (SourceImage srcImg part resize) ->+    createImageFromImage srcImg part resize dest+  (CopyOnWrite backingImg) -> createCOWImage backingImg dest+  (From name resize) -> getLatestImageByName (SharedImageName name) >>= maybe+    (errorExitL (printf "Nothing found for %s." (show (SharedImageName name))))+    (\sharedImg ->+      materializeImageSource (SourceImage sharedImg NoPT resize) dest+    ) -createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 ()+createImageFromImage :: IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e () createImageFromImage src part size out = do   importImage src out   extractPartition part out   resizeImage size out-  where-    extractPartition :: Partition -> Image -> B9 ()-    extractPartition NoPT _ = return ()-    extractPartition (Partition partIndex) (Image outFile Raw _) = do-      (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)-      let tmpFile = outFile <.> "extracted"-      dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)-      cmd (printf "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null" outFile tmpFile blockSize start len)-      cmd (printf "mv '%s' '%s'" tmpFile outFile)-    extractPartition (Partition partIndex) (Image outFile fmt _) =-      error-        (printf "Extract partition %i from image '%s': Invalid format %s" partIndex outFile (imageFileExtension fmt))+ where+  extractPartition :: IsB9 e => Partition -> Image -> Eff e ()+  extractPartition NoPT                  _                     = return ()+  extractPartition (Partition partIndex) (Image outFile Raw _) = do+    (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)+    let tmpFile = outFile <.> "extracted"+    dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)+    cmd+      (printf "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"+              outFile+              tmpFile+              blockSize+              start+              len+      )+    cmd (printf "mv '%s' '%s'" tmpFile outFile)+  extractPartition (Partition partIndex) (Image outFile fmt _) = error+    (printf "Extract partition %i from image '%s': Invalid format %s"+            partIndex+            outFile+            (imageFileExtension fmt)+    )  -- | Convert some 'Image', e.g. a temporary image used during the build phase -- to the final destination.-createDestinationImage :: Image -> ImageDestination -> B9 ()-createDestinationImage buildImg dest =-  case dest of-    (Share name imgType imgResize) -> do-      resizeImage imgResize buildImg-      let shareableImg = changeImageFormat imgType buildImg-      exportAndRemoveImage buildImg shareableImg-      void (shareImage shareableImg (SharedImageName name))-    (LocalFile destImg imgResize) -> do-      resizeImage imgResize buildImg-      exportAndRemoveImage buildImg destImg-    (LiveInstallerImage name repo imgResize) -> do-      resizeImage imgResize buildImg-      let destImg = Image destFile Raw buildImgFs-          (Image _ _ buildImgFs) = buildImg-          destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"-          sizeFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"-          versFile = repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"-      exportAndRemoveImage buildImg destImg-      cmd-        (printf-           "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"-           destFile-           sizeFile)-      buildDate <- getBuildDate-      buildId <- getBuildId-      liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))-    Transient -> return ()+createDestinationImage :: IsB9 e => Image -> ImageDestination -> Eff e ()+createDestinationImage buildImg dest = case dest of+  (Share name imgType imgResize) -> do+    resizeImage imgResize buildImg+    let shareableImg = changeImageFormat imgType buildImg+    exportAndRemoveImage buildImg shareableImg+    void (shareImage shareableImg (SharedImageName name))+  (LocalFile destImg imgResize) -> do+    resizeImage imgResize buildImg+    exportAndRemoveImage buildImg destImg+  (LiveInstallerImage name repo imgResize) -> do+    resizeImage imgResize buildImg+    let+      destImg = Image destFile Raw buildImgFs+      (Image _ _ buildImgFs) = buildImg+      destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"+      sizeFile =+        repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"+      versFile =+        repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"+    exportAndRemoveImage buildImg destImg+    cmd+      (printf+        "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"+        destFile+        sizeFile+      )+    buildDate <- getBuildDate+    buildId   <- getBuildId+    liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))+  Transient -> return () -createEmptyImage :: String -> FileSystem -> ImageType -> ImageSize -> Image -> B9 ()+createEmptyImage+  :: IsB9 e => String -> FileSystem -> ImageType -> ImageSize -> Image -> Eff e () createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType')-  | fsType /= fsType' =-    error-      (printf-         "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."-         (show fsType)-         (show fsType'))-  | imgType /= imgType' =-    error-      (printf-         "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."-         (show imgType)-         (show imgType'))+  | fsType /= fsType' = error+    (printf+      "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."+      (show fsType)+      (show fsType')+    )+  | imgType /= imgType' = error+    (printf+      "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."+      (show imgType)+      (show imgType')+    )   | otherwise = do     let (Image imgFile imgFmt imgFs) = dest-        qemuImgOpts = conversionOptions imgFmt+        qemuImgOpts                  = conversionOptions imgFmt     dbgL-      (printf "Creating empty raw image '%s' with size %s and options %s" imgFile (toQemuSizeOptVal imgSize) qemuImgOpts)+      (printf "Creating empty raw image '%s' with size %s and options %s"+              imgFile+              (toQemuSizeOptVal imgSize)+              qemuImgOpts+      )     cmd-      (printf-         "qemu-img create -f %s %s '%s' '%s'"-         (imageFileExtension imgFmt)-         qemuImgOpts-         imgFile-         (toQemuSizeOptVal imgSize))+      (printf "qemu-img create -f %s %s '%s' '%s'"+              (imageFileExtension imgFmt)+              qemuImgOpts+              imgFile+              (toQemuSizeOptVal imgSize)+      )     case (imgFmt, imgFs) of       (Raw, Ext4_64) -> do         let fsCmd = "mkfs.ext4"@@ -238,18 +276,27 @@         let fsCmd = "mkfs.ext4"         dbgL (printf "Creating file system %s" (show imgFs))         cmd (printf "%s -F -L '%s' -O ^64bit -q '%s'" fsCmd fsLabel imgFile)-      (it, fs) -> error (printf "Cannot create file system %s in image type %s" (show fs) (show it))+      (it, fs) -> error+        (printf "Cannot create file system %s in image type %s"+                (show fs)+                (show it)+        ) -createCOWImage :: Image -> Image -> B9 ()+createCOWImage :: IsB9 e => Image -> Image -> Eff e () createCOWImage (Image backingFile _ _) (Image imgOut imgFmt _) = do   dbgL (printf "Creating COW image '%s' backed by '%s'" imgOut backingFile)-  cmd (printf "qemu-img create -f %s -o backing_file='%s' '%s'" (imageFileExtension imgFmt) backingFile imgOut)+  cmd+    (printf "qemu-img create -f %s -o backing_file='%s' '%s'"+            (imageFileExtension imgFmt)+            backingFile+            imgOut+    )  -- | Resize an image, including the file system inside the image.-resizeImage :: ImageResize -> Image -> B9 ()+resizeImage :: IsB9 e => ImageResize -> Image -> Eff e () resizeImage KeepSize _ = return ()-resizeImage (Resize newSize) (Image img Raw fs)-  | fs == Ext4 || fs == Ext4_64 = do+resizeImage (Resize newSize) (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =+  do     let sizeOpt = toQemuSizeOptVal newSize     dbgL (printf "Resizing ext4 filesystem on raw image to %s" sizeOpt)     cmd (printf "e2fsck -p '%s'" img)@@ -258,36 +305,38 @@   let sizeOpt = toQemuSizeOptVal newSize   dbgL (printf "Resizing image to %s" sizeOpt)   cmd (printf "qemu-img resize -q '%s' %s" img sizeOpt)-resizeImage ShrinkToMinimum (Image img Raw fs)-  | fs == Ext4 || fs == Ext4_64 = do+resizeImage ShrinkToMinimum (Image img Raw fs) | fs == Ext4 || fs == Ext4_64 =+  do     dbgL "Shrinking image to minimum size"     cmd (printf "e2fsck -p '%s'" img)     cmd (printf "resize2fs -f -M '%s'" img)-resizeImage _ img = error (printf "Invalid image type or filesystem, cannot resize image: %s" (show img))+resizeImage _ img = error+  (printf "Invalid image type or filesystem, cannot resize image: %s" (show img)+  )  -- | Import a disk image from some external source into the build directory -- if necessary convert the image.-importImage :: Image -> Image -> B9 ()+importImage :: IsB9 e => Image -> Image -> Eff e () importImage imgIn imgOut@(Image imgOutPath _ _) = do   alreadyThere <- liftIO (doesFileExist imgOutPath)   unless alreadyThere (convert False imgIn imgOut)  -- | Export a disk image from the build directory; if necessary convert the image.-exportImage :: Image -> Image -> B9 ()+exportImage :: IsB9 e => Image -> Image -> Eff e () exportImage = convert False  -- | Export a disk image from the build directory; if necessary convert the image.-exportAndRemoveImage :: Image -> Image -> B9 ()+exportAndRemoveImage :: IsB9 e => Image -> Image -> Eff e () exportAndRemoveImage = convert True  -- | Convert an image in the build directory to another format and return the new image.-convertImage :: Image -> Image -> B9 ()+convertImage :: IsB9 e => Image -> Image -> Eff e () convertImage imgIn imgOut@(Image imgOutPath _ _) = do   alreadyThere <- liftIO (doesFileExist imgOutPath)   unless alreadyThere (convert True imgIn imgOut)  -- | Convert/Copy/Move images-convert :: Bool -> Image -> Image -> B9 ()+convert :: IsB9 e => Bool -> Image -> Image -> Eff e () convert doMove (Image imgIn fmtIn _) (Image imgOut fmtOut _)   | imgIn == imgOut = do     ensureDir imgOut@@ -299,36 +348,39 @@   | otherwise = do     ensureDir imgOut     dbgL-      (printf "Converting %s to %s: '%s' to '%s'" (imageFileExtension fmtIn) (imageFileExtension fmtOut) imgIn imgOut)+      (printf "Converting %s to %s: '%s' to '%s'"+              (imageFileExtension fmtIn)+              (imageFileExtension fmtOut)+              imgIn+              imgOut+      )     cmd-      (printf-         "qemu-img convert -q -f %s -O %s %s '%s' '%s'"-         (imageFileExtension fmtIn)-         (imageFileExtension fmtOut)-         (conversionOptions fmtOut)-         imgIn-         imgOut)+      (printf "qemu-img convert -q -f %s -O %s %s '%s' '%s'"+              (imageFileExtension fmtIn)+              (imageFileExtension fmtOut)+              (conversionOptions fmtOut)+              imgIn+              imgOut+      )     when doMove $ do       dbgL (printf "Removing '%s'" imgIn)       liftIO (removeFile imgIn)  conversionOptions :: ImageType -> String-conversionOptions Vmdk = " -o adapter_type=lsilogic "+conversionOptions Vmdk  = " -o adapter_type=lsilogic " conversionOptions QCow2 = " -o compat=1.1,lazy_refcounts=on "-conversionOptions _ = " "+conversionOptions _     = " "  toQemuSizeOptVal :: ImageSize -> String-toQemuSizeOptVal (ImageSize amount u) =-  show amount ++-  case u of-    GB -> "G"-    MB -> "M"-    KB -> "K"-    B -> ""+toQemuSizeOptVal (ImageSize amount u) = show amount ++ case u of+  GB -> "G"+  MB -> "M"+  KB -> "K"+  B  -> ""  -- | Publish an sharedImage made from an image and image meta data to the -- configured repository-shareImage :: Image -> SharedImageName -> B9 SharedImage+shareImage :: IsB9 e => Image -> SharedImageName -> Eff e SharedImage shareImage buildImg sname@(SharedImageName name) = do   sharedImage <- createSharedImageInCache buildImg sname   infoL (printf "SHARED '%s'" name)@@ -337,20 +389,26 @@  -- | Return a 'SharedImage' with the current build data and build id from the -- name and disk image.-getSharedImageFromImageInfo :: SharedImageName -> Image -> B9 SharedImage+getSharedImageFromImageInfo :: IsB9 e =>  SharedImageName -> Image -> Eff e SharedImage getSharedImageFromImageInfo name (Image _ imgType imgFS) = do   buildId <- getBuildId-  date <- getBuildDate-  return (SharedImage name (SharedImageDate date) (SharedImageBuildId buildId) imgType imgFS)+  date    <- getBuildDate+  return+    (SharedImage name+                 (SharedImageDate date)+                 (SharedImageBuildId buildId)+                 imgType+                 imgFS+    )  -- | Convert the disk image and serialize the base image data structure. -- If the 'maxLocalSharedImageRevisions' configuration is set to @Just n@ -- also delete all but the @n - 1@ newest images from the local cache.-createSharedImageInCache :: Image -> SharedImageName -> B9 SharedImage+createSharedImageInCache :: IsB9 e => Image -> SharedImageName -> Eff e SharedImage createSharedImageInCache img sname@(SharedImageName name) = do   dbgL (printf "CREATING SHARED IMAGE: '%s' '%s'" (ppShow img) name)   sharedImg <- getSharedImageFromImageInfo sname img-  dir <- getSharedImagesCacheDir+  dir       <- getSharedImagesCacheDir   convertImage img (changeImageDirectory dir (sharedImageImage sharedImg))   prettyPrintToFile (dir </> sharedImageFileName sharedImg) sharedImg   dbgL (printf "CREATED SHARED IMAGE IN CACHE '%s'" (ppShow sharedImg))@@ -359,44 +417,45 @@  -- | Publish the latest version of a shared image identified by name to the -- selected repository from the cache.-pushSharedImageLatestVersion :: SharedImageName -> B9 ()+pushSharedImageLatestVersion :: IsB9 e => SharedImageName -> Eff e () pushSharedImageLatestVersion name@(SharedImageName imgName) =-  getLatestSharedImageByNameFromCache name >>=-  maybe+  getLatestSharedImageByNameFromCache name >>= maybe     (errorExitL (printf "Nothing found for %s." (show imgName)))     (\sharedImage -> do-       dbgL (printf "PUSHING '%s'" (ppShow sharedImage))-       pushToSelectedRepo sharedImage-       infoL (printf "PUSHED '%s'" imgName))+      dbgL (printf "PUSHING '%s'" (ppShow sharedImage))+      pushToSelectedRepo sharedImage+      infoL (printf "PUSHED '%s'" imgName)+    )  -- | Upload a shared image from the cache to a selected remote repository-pushToSelectedRepo :: SharedImage -> B9 ()+pushToSelectedRepo :: IsB9 e => SharedImage -> Eff e () pushToSelectedRepo i = do   c <- getSharedImagesCacheDir-  r <- getSelectedRemoteRepo+  MkSelectedRemoteRepo r <- getSelectedRemoteRepo   when (isJust r) $ do     let (Image imgFile' _imgType _imgFS) = sharedImageImage i         cachedImgFile = c </> imgFile'         cachedInfoFile = c </> sharedImageFileName i         repoImgFile = sharedImagesRootDirectory </> imgFile'         repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName i-    pushToRepo (fromJust r) cachedImgFile repoImgFile+    pushToRepo (fromJust r) cachedImgFile  repoImgFile     pushToRepo (fromJust r) cachedInfoFile repoInfoFile  -- | Pull metadata files from all remote repositories.-pullRemoteRepos :: B9 ()+pullRemoteRepos :: IsB9 e => Eff e () pullRemoteRepos = do   repos <- getSelectedRepos   mapM_ dl repos-  where-    dl = pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension)+ where+  dl =+    pullGlob sharedImagesRootDirectory (FileExtension sharedImageFileExtension)  -- | Pull the latest version of an image, either from the selected remote -- repo or from the repo that has the latest version.-pullLatestImage :: SharedImageName -> B9 (Maybe SharedImageBuildId)+pullLatestImage :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImageBuildId) pullLatestImage name@(SharedImageName dbgName) = do   repos <- getSelectedRepos-  let repoPredicate Cache = False+  let repoPredicate Cache           = False       repoPredicate (Remote repoId) = repoId `elem` repoIds       repoIds = map remoteRepoRepoId repos       hasName sharedImage = name == sharedImageName sharedImage@@ -404,18 +463,24 @@   let (Remote repoId, image) = last candidates   if null candidates     then do-      errorL (printf "No shared image named '%s' on these remote repositories: '%s'" dbgName (ppShow repoIds))+      errorL+        (printf+          "No shared image named '%s' on these remote repositories: '%s'"+          dbgName+          (ppShow repoIds)+        )       return Nothing     else do       dbgL (printf "PULLING SHARED IMAGE: '%s'" (ppShow image))       cacheDir <- getSharedImagesCacheDir-      let (Image imgFile' _imgType _fs) = sharedImageImage image-          cachedImgFile = cacheDir </> imgFile'-          cachedInfoFile = cacheDir </> sharedImageFileName image-          repoImgFile = sharedImagesRootDirectory </> imgFile'-          repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName image-          repo = fromJust (lookupRemoteRepo repos repoId)-      pullFromRepo repo repoImgFile cachedImgFile+      let+        (Image imgFile' _imgType _fs) = sharedImageImage image+        cachedImgFile                 = cacheDir </> imgFile'+        cachedInfoFile                = cacheDir </> sharedImageFileName image+        repoImgFile                   = sharedImagesRootDirectory </> imgFile'+        repoInfoFile = sharedImagesRootDirectory </> sharedImageFileName image+        repo                          = fromJust (lookupRemoteRepo repos repoId)+      pullFromRepo repo repoImgFile  cachedImgFile       pullFromRepo repo repoInfoFile cachedInfoFile       infoL (printf "PULLED '%s' FROM '%s'" dbgName repoId)       cleanOldSharedImageRevisionsFromCache name@@ -423,64 +488,73 @@  -- | Return the 'Image' of the latest version of a shared image named 'name' -- from the local cache.-getLatestImageByName :: SharedImageName -> B9 (Maybe Image)+getLatestImageByName :: IsB9 e => SharedImageName -> Eff e (Maybe Image) getLatestImageByName name = do   sharedImage <- getLatestSharedImageByNameFromCache name-  cacheDir <- getSharedImagesCacheDir+  cacheDir    <- getSharedImagesCacheDir   let image = changeImageDirectory cacheDir . sharedImageImage <$> sharedImage   case image of-    Just i -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))+    Just i  -> dbgL (printf "USING SHARED SOURCE IMAGE '%s'" (show i))     Nothing -> errorL (printf "SOURCE IMAGE '%s' NOT FOUND" (show name))   return image  -- | Return the latest version of a shared image named 'name' from the local cache.-getLatestSharedImageByNameFromCache :: SharedImageName -> B9 (Maybe SharedImage)+getLatestSharedImageByNameFromCache :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImage) getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do   imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName)   case reverse imgs of-    (Cache, sharedImage):_rest -> return (Just sharedImage)-    _ -> do+    (Cache, sharedImage) : _rest -> return (Just sharedImage)+    _                            -> do       errorL (printf "No image(s) named '%s' found." dbgName)       return Nothing  -- | Return a list of all existing sharedImages from cached repositories.-getSharedImages :: B9 [(Repository, [SharedImage])]+getSharedImages :: IsB9 e => Eff e [(Repository, [SharedImage])] getSharedImages = do-  reposAndFiles <- repoSearch sharedImagesRootDirectory (FileExtension sharedImageFileExtension)-  mapM (\(repo, files) -> (repo, ) . catMaybes <$> mapM consult' files) reposAndFiles-  where-    consult' f = do-      r <- liftIO (try (consult f))-      case r of-        Left (e :: SomeException) -> do-          dbgL (printf "Failed to load shared image meta-data from '%s': '%s'" (takeFileName f) (show e))-          dbgL (printf "Removing bad meta-data file '%s'" f)-          liftIO (removeFile f)-          return Nothing-        Right c -> return (Just c)+  reposAndFiles <- repoSearch sharedImagesRootDirectory+                              (FileExtension sharedImageFileExtension)+  mapM (\(repo, files) -> (repo, ) . catMaybes <$> mapM consult' files)+       reposAndFiles+ where+  consult' f = do+    r <- liftIO (try (consult f))+    case r of+      Left (e :: SomeException) -> do+        dbgL+          (printf "Failed to load shared image meta-data from '%s': '%s'"+                  (takeFileName f)+                  (show e)+          )+        dbgL (printf "Removing bad meta-data file '%s'" f)+        liftIO (removeFile f)+        return Nothing+      Right c -> return (Just c)  -- | Find shared images and the associated repos from two predicates. The result -- is the concatenated result of the sorted shared images satisfying 'imgPred'.-lookupSharedImages :: (Repository -> Bool) -> (SharedImage -> Bool) -> B9 [(Repository, SharedImage)]+lookupSharedImages+  ::IsB9 e =>  (Repository -> Bool)+  -> (SharedImage -> Bool)+  -> Eff e [(Repository, SharedImage)] lookupSharedImages repoPred imgPred = do   xs <- getSharedImages-  let rs = [(r, s) | (r, ss) <- xs, s <- ss]+  let rs           = [ (r, s) | (r, ss) <- xs, s <- ss ]       matchingRepo = filter (repoPred . fst) rs-      matchingImg = filter (imgPred . snd) matchingRepo-      sorted = sortBy (compare `on` snd) matchingImg+      matchingImg  = filter (imgPred . snd) matchingRepo+      sorted       = sortBy (compare `on` snd) matchingImg   return (mconcat (pure <$> sorted))  -- | Return either all remote repos or just the single selected repo.-getSelectedRepos :: B9 [RemoteRepo]+getSelectedRepos ::IsB9 e =>  Eff e [RemoteRepo] getSelectedRepos = do-  allRepos <- getRemoteRepos-  selectedRepo <- getSelectedRemoteRepo+  allRepos     <- getRemoteRepos+  MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo   let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo   return repos  -- | Return the path to the sub directory in the cache that contains files of -- shared images.-getSharedImagesCacheDir :: B9 FilePath+getSharedImagesCacheDir :: IsB9 e => Eff e FilePath getSharedImagesCacheDir = do   cacheDir <- localRepoDir <$> getRepoCache   return (cacheDir </> sharedImagesRootDirectory)@@ -488,24 +562,29 @@ -- | Depending on the 'maxLocalSharedImageRevisions' 'B9Config' settings either -- do nothing or delete all but the configured number of most recent shared -- images with the given name from the local cache.-cleanOldSharedImageRevisionsFromCache :: SharedImageName -> B9 ()+cleanOldSharedImageRevisionsFromCache :: IsB9 e => SharedImageName -> Eff e () cleanOldSharedImageRevisionsFromCache sn = do   b9Cfg <- getConfig   forM_ (b9Cfg ^. maxLocalSharedImageRevisions) $ \maxRevisions -> do     toDelete <- take maxRevisions <$> newestSharedImages-    imgDir <- getSharedImagesCacheDir+    imgDir   <- getSharedImagesCacheDir     let filesToDelete = (imgDir </>) <$> (infoFiles ++ imgFiles)-        infoFiles = sharedImageFileName <$> toDelete-        imgFiles = imageFileName . sharedImageImage <$> toDelete+        infoFiles     = sharedImageFileName <$> toDelete+        imgFiles      = imageFileName . sharedImageImage <$> toDelete     unless (null filesToDelete) $ do-      traceL (printf "DELETING %d OBSOLETE REVISIONS OF: %s" (length filesToDelete) (show sn))-      mapM_ traceL filesToDelete+      traceL+        (printf "DELETING %d OBSOLETE REVISIONS OF: %s"+                (length filesToDelete)+                (show sn)+        )+      mapM_ traceL         filesToDelete       mapM_ removeIfExists filesToDelete-  where-    newestSharedImages :: B9 [SharedImage]-    newestSharedImages = reverse . map snd <$> lookupSharedImages (== Cache) ((sn ==) . sharedImageName)-    removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists-      where-        handleExists e-          | isDoesNotExistError e = return ()-          | otherwise = throwIO e+ where+  newestSharedImages :: IsB9 e => Eff e [SharedImage]+  newestSharedImages = reverse . map snd <$> lookupSharedImages+    (== Cache)+    ((sn ==) . sharedImageName)+  removeIfExists fileName = liftIO $ removeFile fileName `catch` handleExists+   where+    handleExists e | isDoesNotExistError e = return ()+                   | otherwise             = throwIO e

@@ -10,30 +10,36 @@   ( Environment()   , fromStringPairs   , addStringBinding-  , insertPositionalArguments-  , EnvironmentReaderT-  , MonadEnvironment-  , runEnvironmentReaderT+  , addLocalStringBinding+  , addPositionalArguments+  , addLocalPositionalArguments+  , EnvironmentReader+  , hasKey+  , runEnvironmentReader   , askEnvironment   , localEnvironment   , lookupOrThrow   , lookupEither   , KeyNotFound(..)   , DuplicateKey(..)-  ) where+  )+where -import           Control.Arrow               ((***))-import           Control.Exception           (Exception)-import           Control.Monad.Catch         (MonadThrow, throwM)-import           Control.Monad.Reader+import           B9.B9Error+import           Control.Arrow                  ( (***) )+import           Control.Exception              ( Exception )+import           Control.Eff                   as Eff+import           Control.Eff.Reader.Lazy       as Eff import           Control.Parallel.Strategies import           Data.Data-import           Data.HashMap.Strict         (HashMap)-import qualified Data.HashMap.Strict         as HashMap-import           Data.Maybe                  (maybe)-import           Data.Text.Lazy              (Text)-import qualified Data.Text.Lazy              as Text-import           GHC.Generics                (Generic)+import           Data.HashMap.Strict            ( HashMap )+import qualified Data.HashMap.Strict           as HashMap+import           Data.Maybe                     ( maybe+                                                , isJust+                                                )+import           Data.Text.Lazy                 ( Text )+import qualified Data.Text.Lazy                as Text+import           GHC.Generics                   ( Generic )  -- | A map of textual keys to textual values. --@@ -46,20 +52,38 @@ instance NFData Environment  instance Semigroup Environment where-  e1 <> e2 =-    MkEnvironment-      { nextPosition =-          case (nextPosition e1, nextPosition e2) of-            (0, 0) -> 0-            (0, p2) -> p2-            (p1, 0) -> p1-            _ -> error ("Overlapping positional arguments (<>): (" ++ show e1 ++ ") <> (" ++ show e2 ++ ")")-      , fromEnvironment =-          let i = HashMap.intersection (fromEnvironment e1) (fromEnvironment e2)-           in if HashMap.null i-                then fromEnvironment e1 <> fromEnvironment e2-                else error ("Overlapping entries (<>): (" ++ show e1 ++ ") <> (" ++ show e2 ++ "): (" ++ show i ++ ")")-      }+  e1 <> e2 = MkEnvironment+    { nextPosition    = case (nextPosition e1, nextPosition e2) of+                          (0 , 0 ) -> 0+                          (0 , p2) -> p2+                          (p1, 0 ) -> p1+                          _        -> error+                            (  "Overlapping positional arguments (<>): ("+                            ++ show e1+                            ++ ") <> ("+                            ++ show e2+                            ++ ")"+                            )+    , fromEnvironment = let i  = HashMap.intersection h1 h2+                            h1 = fromEnvironment e1+                            h2 = fromEnvironment e2+                        in  if HashMap.null i || all+                               (\k -> HashMap.lookup k h1 == HashMap.lookup k h2+                               )+                               (HashMap.keys i)+                            then+                              h1 <> h2+                            else+                              error+                                (  "Overlapping entries (<>): ("+                                ++ show e1+                                ++ ") <> ("+                                ++ show e2+                                ++ "): ("+                                ++ show i+                                ++ ")"+                                )+    }  instance Monoid Environment where   mempty = MkEnvironment 0 HashMap.empty@@ -71,52 +95,84 @@ -- Note that the Environment contains an index of the next position. -- -- @since 0.5.62-insertPositionalArguments :: [Text] -> Environment -> Environment-insertPositionalArguments =-  flip (foldr (\arg (MkEnvironment i e) -> MkEnvironment (i + 1) (HashMap.insert (Text.pack ("arg_" ++ show i)) arg e)))+addPositionalArguments :: [Text] -> Environment -> Environment+addPositionalArguments = flip+  (foldr+    (\arg (MkEnvironment i e) -> MkEnvironment+      (i + 1)+      (HashMap.insert (Text.pack ("arg_" ++ show i)) arg e)+    )+  ) --- | Create an 'Environment' from a list of pairs ('String's)++-- | Convenient wrapper around 'addPositionalArguments' and 'localEnvironment'. --+-- @since 0.5.65+addLocalPositionalArguments :: Member EnvironmentReader e => [String] -> Eff e a -> Eff e a+addLocalPositionalArguments extraPositional = localEnvironment appendVars+  where+    appendVars = addPositionalArguments (Text.pack <$> extraPositional)++-- | Create an 'Environment' from a list of pairs ('String's).+-- Duplicated entries are ignored.+-- -- @since 0.5.62 fromStringPairs :: [(String, String)] -> Environment-fromStringPairs = MkEnvironment 0 . HashMap.fromList . fmap (Text.pack *** Text.pack)+fromStringPairs =+  MkEnvironment 0 . HashMap.fromList . fmap (Text.pack *** Text.pack) --- | Insert a value into an 'Environment'.+-- | Insert a value into an 'Environment'. Thrown an exception when the+-- key already exists, and the value is different. -- -- @since 0.5.62-addStringBinding :: MonadThrow m => (String, String) -> Environment -> m Environment-addStringBinding (k, vNew) env =-  case HashMap.lookup (Text.pack k) (fromEnvironment env) of-    Just vOld -> throwM (MkDuplicateKey (Text.pack k) vOld (Text.pack vNew))-    Nothing ->-      pure (MkEnvironment (nextPosition env) (HashMap.insert (Text.pack k) (Text.pack vNew) (fromEnvironment env)))+addStringBinding+  :: Member ExcB9 e => (String, String) -> Environment -> Eff e Environment+addStringBinding (kStr, vNewStr) env =+  let k    = Text.pack kStr+      vNew = Text.pack vNewStr+      h    = fromEnvironment env+  in  case HashMap.lookup k h of+        Just vOld | vOld /= vNew ->+          throwSomeException (MkDuplicateKey k vOld vNew)+        _ -> pure (MkEnvironment (nextPosition env) (HashMap.insert k vNew h)) --- | A monad transformer providing a 'MonadReader' instance for 'Environment'+-- | Insert a value into an 'Environment' like 'addStringBinding',+-- but add it to the environment of the given effect, as in 'localEnvironment'. ----- @since 0.5.62-type EnvironmentReaderT m a = ReaderT Environment m a+-- @since 0.5.65+addLocalStringBinding+  :: (Member EnvironmentReader e, Member ExcB9 e)+  => (String, String) -> Eff e a-> Eff e a+addLocalStringBinding binding action =+  do e <- askEnvironment+     e' <- addStringBinding binding e+     localEnvironment (const e') action --- | A constraint on a monad @m@ ensuring (read-only) access to an 'Environment'+-- | A monad transformer providing a 'MonadReader' instance for 'Environment' -- -- @since 0.5.62-type MonadEnvironment m = MonadReader Environment m+type EnvironmentReader = Reader Environment  -- | Run a 'ReaderT' of 'Environment'. -- -- @since 0.5.62-runEnvironmentReaderT :: Environment -> EnvironmentReaderT m a -> m a-runEnvironmentReaderT = flip runReaderT+runEnvironmentReader :: Environment -> Eff (EnvironmentReader ': e) a -> Eff e a+runEnvironmentReader = runReader  -- | Get the current 'Environment' -- -- @since 0.5.62-askEnvironment :: MonadEnvironment m => m Environment+askEnvironment :: Member EnvironmentReader e => Eff e Environment askEnvironment = ask  -- | Run a computation with a modified 'Environment' -- -- @since 0.5.62-localEnvironment :: MonadEnvironment m => (Environment -> Environment) -> m a -> m a+localEnvironment+  :: Member EnvironmentReader e+  => (Environment -> Environment)+  -> Eff e a+  -> Eff e a localEnvironment = local  -- | Lookup a key for a value.@@ -125,10 +181,12 @@ -- in the 'Environment'. -- -- @Since 0.5.62-lookupOrThrow :: (MonadThrow m, MonadEnvironment m) => Text -> m Text+lookupOrThrow :: ('[ExcB9, EnvironmentReader] <:: e) => Text -> Eff e Text lookupOrThrow key = do   env <- askEnvironment-  maybe (throwM (MkKeyNotFound key env)) return (HashMap.lookup key (fromEnvironment env))+  maybe (throwSomeException (MkKeyNotFound key env))+        return+        (HashMap.lookup key (fromEnvironment env))  -- | Lookup a key for a value. --@@ -136,10 +194,12 @@ -- in the 'Environment', or 'Right' the value. -- -- @Since 0.5.62-lookupEither :: MonadEnvironment m => Text -> m (Either KeyNotFound Text)+lookupEither+  :: Member EnvironmentReader e => Text -> Eff e (Either KeyNotFound Text) lookupEither key = do   env <- askEnvironment-  (return . maybe (Left (MkKeyNotFound key env)) Right) (HashMap.lookup key (fromEnvironment env))+  (return . maybe (Left (MkKeyNotFound key env)) Right)+    (HashMap.lookup key (fromEnvironment env))  -- | An 'Exception' thrown by 'addBinding' indicating that a key already exists. --@@ -165,5 +225,13 @@ instance Show KeyNotFound where   showsPrec _ (MkKeyNotFound key env) =     let keys = unlines (Text.unpack <$> HashMap.keys (fromEnvironment env))-     in showString "Invalid template parameter: \"" .-        showString (Text.unpack key) . showString "\".\nValid variables:\n" . showString keys+    in  showString "Invalid template parameter: \""+          . showString (Text.unpack key)+          . showString "\".\nValid variables:\n"+          . showString keys++-- | A predicate that is satisfied when a key exists in the environment.+--+-- @since 0.5.64+hasKey :: Member EnvironmentReader e => Text -> Eff e Bool+hasKey k = isJust . HashMap.lookup k . fromEnvironment <$> askEnvironment

@@ -4,81 +4,83 @@   , supportedImageTypes   , logLibVirtLXCConfig   , module X-  )-where+  ) where -import           Control.Monad.IO.Class         ( liftIO )-import           System.Directory-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.B9Config.LibVirtLXC        as X-import           System.IO.B9Extras             ( UUID()-                                                , randomUUID-                                                )+import B9.B9Config (getB9Config, libVirtLXCConfigs)+import B9.B9Config.LibVirtLXC as X+import B9.B9Exec+import B9.B9Logging+import B9.BuildInfo+import B9.DiskImages+import B9.ExecEnv+import B9.ShellScript+import Control.Eff+import Control.Lens (view)+import Control.Monad.IO.Class (liftIO)+import Data.Char (toLower)+import System.Directory+import System.FilePath+import System.IO.B9Extras (UUID(), randomUUID)+import Text.Printf (printf) -logLibVirtLXCConfig :: LibVirtLXCConfig -> B9 ()+logLibVirtLXCConfig :: CommandIO e => LibVirtLXCConfig -> Eff e () 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-    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]]--  execute (Context scriptDirHost _uuid domainFile cfg) = do-    let virsh = virshCommand cfg-    cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile+runInEnvironment ::+     forall e. (Member BuildInfoReader e, CommandIO e)+  => ExecEnv+  -> Script+  -> Eff e Bool+runInEnvironment env scriptIn =+  if emptyScript scriptIn+    then return True+    else setUp >>= execute+  where+    setUp = do+      mcfg <- view libVirtLXCConfigs <$> getB9Config+      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]]+    execute :: Context -> Eff e Bool+    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"--  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+      liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)+    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 +data Context =+  Context FilePath+          UUID+          FilePath+          LibVirtLXCConfig  initScript :: String initScript = "init.sh"@@ -86,134 +88,109 @@ 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"+osArch e =+  case cpuArch (envResources e) of+    X86_64 -> "x86_64"+    I386 -> "i686"  libVirtNetwork :: Maybe String -> [String] libVirtNetwork Nothing = []-libVirtNetwork (Just n) =-  [ "<interface type='network'>"-  , "  <source network='" ++ n ++ "'/>"-  , "</interface>"-  ]+libVirtNetwork (Just n) = ["<interface type='network'>", "  <source network='" ++ n ++ "'/>", "</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'")--  fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"+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 ++ "'/>"  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 (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

@@ -4,6 +4,13 @@ shall interfere with each other. This is accomplished by refraining from automatic cache updates from/to remote repositories.-} module B9.Repository (initRepoCache+                     ,RepoCacheReader+                     ,getRepoCache+                     ,withRemoteRepos+                     ,withSelectedRemoteRepo+                     ,getSelectedRemoteRepo+                     ,SelectedRemoteRepoReader+                     ,SelectedRemoteRepo(..)                      ,initRemoteRepo                      ,cleanRemoteRepo                      ,remoteRepoCheckSshPrivKey@@ -12,16 +19,91 @@                      ,lookupRemoteRepo                      ,module X) where +import B9.B9Config+import B9.B9Error import Control.Monad+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Lens import Control.Monad.IO.Class #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif+import Data.Maybe import Text.Printf import System.FilePath import System.Directory import B9.B9Config.Repository as X import System.IO.B9Extras++-- | Initialize the local repository cache directory and the 'RemoteRepo's.+-- Run the given action with a 'B9Config' that contains the initialized+-- repositories in '_remoteRepos'.+--+-- @since 0.5.65+withRemoteRepos :: (Member B9ConfigReader e, Lifted IO e)+  => Eff (RepoCacheReader ': e) a -> Eff e a+withRemoteRepos f = do+      cfg <- getB9Config+      repoCache <- lift (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg)))+      remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg)+      let setRemoteRepos = remoteRepos .~ remoteRepos'+      localB9Config setRemoteRepos (runReader repoCache f)++-- | Alias for a 'Reader' 'Eff'ect that reads a list of 'RemoteRepo's.+--+-- @since 0.5.65+type RepoCacheReader = Reader RepoCache++-- | Ask for the 'RepoCache' initialized by 'withRemoteRepos'.+--+-- @since 0.5.65+getRepoCache :: Member RepoCacheReader e => Eff e RepoCache+getRepoCache = ask++-- | Run a 'SelectedRemoteRepoReader' with the 'SelectedRemoteRepo' selected+-- in the 'B9Config'.+--+-- If the selected repo does not exist, and exception is thrown.+--+-- @since 0.5.65+withSelectedRemoteRepo+  :: (Member B9ConfigReader e, Member ExcB9 e)+  => Eff (SelectedRemoteRepoReader ': e) a+  -> Eff e a+withSelectedRemoteRepo e = do+  remoteRepos' <- _remoteRepos <$> getB9Config+  mSelectedRepoName <- _repository <$> getB9Config+  case mSelectedRepoName of+    Nothing -> runReader (MkSelectedRemoteRepo Nothing) e+    Just selectedRepoName ->+      case lookupRemoteRepo remoteRepos' selectedRepoName of+        Nothing ->+          throwB9Error+            (printf "selected remote repo '%s' not configured, valid remote repos are: '%s'"+                    (show selectedRepoName)+                    (show remoteRepos'))+        Just r ->+          runReader (MkSelectedRemoteRepo (Just r)) e++-- | Contains the 'Just' the 'RemoteRepo' selected by the 'B9Config' value '_repository',+-- or 'Nothing' of no 'RemoteRepo' was selected in the 'B9Config'.+--+-- @since 0.5.65+newtype SelectedRemoteRepo = MkSelectedRemoteRepo { fromSelectedRemoteRepo :: Maybe RemoteRepo }++-- | Alias for a 'Reader' 'Eff'ect that reads the 'RemoteRepo'+-- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'.+--+-- @since 0.5.65+type SelectedRemoteRepoReader = Reader SelectedRemoteRepo++-- | Ask for the 'RemoteRepo'+-- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'.+--+-- @since 0.5.65+getSelectedRemoteRepo :: Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo+getSelectedRemoteRepo = ask  -- | Initialize the local repository cache directory. initRepoCache :: MonadIO m => SystemPath -> m RepoCache

@@ -1,23 +1,30 @@ {-| Effectful functions executing shared image respository operations.     See "B9.Repository" -}-module B9.RepositoryIO (repoSearch-                       ,pushToRepo-                       ,pullFromRepo-                       ,pullGlob-                       ,Repository(..)-                       ,toRemoteRepository-                       ,FilePathGlob(..)) where+module B9.RepositoryIO+  ( repoSearch+  , pushToRepo+  , pullFromRepo+  , pullGlob+  , Repository(..)+  , toRemoteRepository+  , FilePathGlob(..)+  ) where +import B9.B9Config (getRemoteRepos)+import B9.B9Logging+import B9.B9Exec import B9.Repository-import B9.B9Monad-import System.IO.B9Extras (ensureDir)-import Data.List+import Control.Eff import Control.Monad.IO.Class+import Data.List import System.Directory import System.FilePath+import System.IO.B9Extras (ensureDir) import Text.Printf (printf) -data Repository = Cache | Remote String+data Repository+  = Cache+  | Remote String   deriving (Eq, Ord, Read, Show)  -- | Convert a `RemoteRepo` down to a mere `Repository`@@ -27,80 +34,73 @@ -- | Find files which are in 'subDir' and match 'glob' in the repository -- cache. NOTE: This operates on the repository cache, but does not enforce a -- repository cache update.-repoSearch :: FilePath -> FilePathGlob -> B9 [(Repository, [FilePath])]+repoSearch ::+     forall e. (CommandIO e, Member RepoCacheReader e)+  => FilePath+  -> FilePathGlob+  -> Eff e [(Repository, [FilePath])] repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches-  where remoteRepoMatches = do-          remoteRepos <- getRemoteRepos-          mapM remoteRepoSearch remoteRepos--        localMatches :: B9 (Repository, [FilePath])-        localMatches = do-          cache <- getRepoCache-          let dir = localRepoDir cache </> subDir-          files <- findGlob dir-          return (Cache, files)--        remoteRepoSearch :: RemoteRepo -> B9 (Repository, [FilePath])-        remoteRepoSearch repo = do-          cache <- getRepoCache-          let dir = remoteRepoCacheDir cache repoId </> subDir-              (RemoteRepo repoId _ _ _ _) = repo-          files <- findGlob dir-          return (Remote repoId, files)--        findGlob :: FilePath -> B9 [FilePath]-        findGlob dir = do-          traceL (printf "reading contents of directory '%s'" dir)-          ensureDir (dir ++ "/")-          files <- liftIO (getDirectoryContents dir)-          return ((dir </>) <$> filter (matchGlob glob) files)+  where+    remoteRepoMatches = do+      remoteRepos <- getRemoteRepos+      mapM remoteRepoSearch remoteRepos+    localMatches :: Eff e (Repository, [FilePath])+    localMatches = do+      cache <- getRepoCache+      let dir = localRepoDir cache </> subDir+      files <- findGlob dir+      return (Cache, files)+    remoteRepoSearch :: RemoteRepo -> Eff e (Repository, [FilePath])+    remoteRepoSearch repo = do+      cache <- getRepoCache+      let dir = remoteRepoCacheDir cache repoId </> subDir+          (RemoteRepo repoId _ _ _ _) = repo+      files <- findGlob dir+      return (Remote repoId, files)+    findGlob :: FilePath -> Eff e [FilePath]+    findGlob dir = do+      traceL (printf "reading contents of directory '%s'" dir)+      ensureDir (dir ++ "/")+      files <- liftIO (getDirectoryContents dir)+      return ((dir </>) <$> filter (matchGlob glob) files)  -- | Push a file from the cache to a remote repository-pushToRepo :: RemoteRepo -> FilePath -> FilePath -> B9 ()+pushToRepo :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e () pushToRepo repo@(RemoteRepo repoId _ _ _ _) src dest = do   dbgL (printf "PUSHING '%s' TO REPO '%s'" (takeFileName src) repoId)   cmd (repoEnsureDirCmd repo dest)   cmd (pushCmd repo src dest)  -- | Pull a file from a remote repository to cache-pullFromRepo :: RemoteRepo -> FilePath -> FilePath -> B9 ()-pullFromRepo repo@(RemoteRepo repoId-                              rootDir-                              _key-                              (SshRemoteHost (host, _port))-                              (SshRemoteUser user)) src dest = do+pullFromRepo ::  (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()+pullFromRepo repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest = do   dbgL (printf "PULLING '%s' FROM REPO '%s'" (takeFileName src) repoId)-  cmd (printf "rsync -rtv -e 'ssh %s' '%s@%s:%s' '%s'"-              (sshOpts repo)-              user-              host-              (rootDir </> src)-              dest)+  cmd (printf "rsync -rtv -e 'ssh %s' '%s@%s:%s' '%s'" (sshOpts repo) user host (rootDir </> src) dest)  -- | Push a file from the cache to a remote repository-pullGlob :: FilePath -> FilePathGlob -> RemoteRepo -> B9 ()-pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host,_port)) (SshRemoteUser user)) = do-    cache <- getRepoCache-    infoL (printf "SYNCING REPO METADATA '%s'" repoId)-    let c =-            printf-                "rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'"-                (globToPattern glob)-                (sshOpts repo)-                user-                host-                (rootDir </> subDir)-                destDir-        destDir = repoCacheDir </> subDir-        repoCacheDir = remoteRepoCacheDir cache repoId-    ensureDir destDir-    cmd c+pullGlob ::  (CommandIO e, Member RepoCacheReader e) => FilePath -> FilePathGlob -> RemoteRepo -> Eff e ()+pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) = do+  cache <- getRepoCache+  infoL (printf "SYNCING REPO METADATA '%s'" repoId)+  let c =+        printf+          "rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'"+          (globToPattern glob)+          (sshOpts repo)+          user+          host+          (rootDir </> subDir)+          destDir+      destDir = repoCacheDir </> subDir+      repoCacheDir = remoteRepoCacheDir cache repoId+  ensureDir destDir+  cmd c  -- | Express a pattern for file paths, used when searching repositories.-newtype FilePathGlob = FileExtension String+newtype FilePathGlob =+  FileExtension String  -- * Internals- globToPattern :: FilePathGlob -> String globToPattern (FileExtension ext) = "*." ++ ext @@ -111,36 +111,26 @@ -- | A shell command string for invoking rsync to push a path to a remote host -- via ssh. pushCmd :: RemoteRepo -> FilePath -> FilePath -> String-pushCmd repo@(RemoteRepo _repoId-                         rootDir-                         _key-                         (SshRemoteHost (host, _port))-                         (SshRemoteUser user)) src dest =-  printf "rsync -rtv --inplace --ignore-existing -e 'ssh %s' '%s' '%s'"-         (sshOpts repo) src sshDest-  where sshDest = printf "%s@%s:%s/%s" user host rootDir dest :: String+pushCmd repo@(RemoteRepo _repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) src dest =+  printf "rsync -rtv --inplace --ignore-existing -e 'ssh %s' '%s' '%s'" (sshOpts repo) src sshDest+  where+    sshDest = printf "%s@%s:%s/%s" user host rootDir dest :: String  -- | A shell command string for invoking rsync to create the directories for a -- file push. repoEnsureDirCmd :: RemoteRepo -> FilePath -> String-repoEnsureDirCmd repo@(RemoteRepo _repoId-                                   rootDir-                                   _key-                                   (SshRemoteHost (host, _port))-                                   (SshRemoteUser user)) dest =-  printf "ssh %s %s@%s mkdir -p '%s'"-         (sshOpts repo)-         user-         host-         (rootDir </> takeDirectory dest)+repoEnsureDirCmd repo@(RemoteRepo _repoId rootDir _key (SshRemoteHost (host, _port)) (SshRemoteUser user)) dest =+  printf "ssh %s %s@%s mkdir -p '%s'" (sshOpts repo) user host (rootDir </> takeDirectory dest)  sshOpts :: RemoteRepo -> String-sshOpts (RemoteRepo _repoId-                    _rootDir-                    (SshPrivKey key)-                    (SshRemoteHost (_host, port))-                    _user) =-  unwords ["-o","StrictHostKeyChecking=no"-          ,"-o","UserKnownHostsFile=/dev/null"-          ,"-o",printf "Port=%i" port-          ,"-o","IdentityFile=" ++ key]+sshOpts (RemoteRepo _repoId _rootDir (SshPrivKey key) (SshRemoteHost (_host, port)) _user) =+  unwords+    [ "-o"+    , "StrictHostKeyChecking=no"+    , "-o"+    , "UserKnownHostsFile=/dev/null"+    , "-o"+    , printf "Port=%i" port+    , "-o"+    , "IdentityFile=" ++ key+    ]

@@ -1,15 +1,18 @@ -- | Convenient Shake 'Action's for 'B9' rules.-module B9.Shake.Actions (b9InvocationAction, buildB9File) where+module B9.Shake.Actions+  ( b9InvocationAction+  , buildB9File+  ) where -import Development.Shake-import Development.Shake.FilePath-import B9+import           B9+import           Control.Lens               ((?~))+import           Development.Shake  -- | Convert a 'B9Invocation' action into a Shake 'Action'. This is just--- an alias for 'execB9ConfigAction' since 'Action' is an instance of 'MonadIO'--- and 'execB9ConfigAction' work on any .-b9InvocationAction :: B9ConfigAction Action a -> B9ConfigOverride -> Action a-b9InvocationAction = execB9ConfigAction+-- an alias for 'runB9ConfigActionWithOverrides' since 'Action' is an instance of 'MonadIO'+-- and 'runB9ConfigActionWithOverrides' work on any .+b9InvocationAction :: B9ConfigAction a -> B9ConfigOverride -> Action a+b9InvocationAction x y = liftIO (runB9ConfigActionWithOverrides x y)  -- | An action that does the equivalent of -- @b9c build -f <b9file> -- (args !! 0) (args !! 1) ... (args !! (length args - 1))@@@ -19,4 +22,6 @@ buildB9File b9Root b9File args = do   let f = b9Root </> b9File   need [f]-  invokeB9 (localRuntimeConfig (appendPositionalArguments args . (buildDirRoot .~ Just b9Root)) (runBuildArtifacts [f]))+  liftIO+    (runB9ConfigAction+       (addLocalPositionalArguments args (localB9Config (projectRoot ?~ b9Root) (runBuildArtifacts [f]))))

@@ -4,72 +4,61 @@   ( customSharedImageAction   , needSharedImage   , enableSharedImageRules-  )-where+  ) where -import           Development.Shake-import           Development.Shake.Classes-import           Development.Shake.Rule-import qualified Data.ByteString               as ByteString-import qualified Data.ByteString.Builder       as Builder-import           Data.ByteString.Builder        ( stringUtf8 )-import qualified Data.ByteString.Lazy          as LazyByteString-import qualified Data.Binary                   as Binary-import           B9+import B9+import qualified Data.Binary as Binary+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Builder as Builder+import Data.ByteString.Builder (stringUtf8)+import qualified Data.ByteString.Lazy as LazyByteString+import Development.Shake+import Development.Shake.Classes+import Development.Shake.Rule  -- | In order to use 'needSharedImage' and 'customSharedImageAction' you need to -- call this action before using any of the aforementioned 'Rules'. enableSharedImageRules :: B9ConfigOverride -> Rules () enableSharedImageRules b9inv = addBuiltinRule noLint sharedImageIdentity go- where-  sharedImageIdentity :: BuiltinIdentity SharedImageName SharedImageBuildId-  sharedImageIdentity (SharedImageName k) (SharedImageBuildId v) =+  where+    sharedImageIdentity :: BuiltinIdentity SharedImageName SharedImageBuildId+    sharedImageIdentity (SharedImageName k) (SharedImageBuildId v) =       Just (LazyByteString.toStrict (Builder.toLazyByteString (stringUtf8 k <> stringUtf8 v)))--  go :: BuiltinRun SharedImageName SharedImageBuildId-  go nameQ mOldBIdBinary dependenciesChanged = do-    mCurrentBId <- getImgBuildId-    case mCurrentBId of-      Just currentBId ->-        let currentBIdBinary = encodeBuildId currentBId--        in  if dependenciesChanged-                 == RunDependenciesChanged-                 && mOldBIdBinary-                 == Just currentBIdBinary-              then return $ RunResult ChangedNothing currentBIdBinary currentBId-              else rebuild (Just currentBIdBinary)-      _ -> rebuild Nothing-   where-    getImgBuildId = execB9ConfigAction (runLookupLocalSharedImage nameQ) b9inv--    encodeBuildId :: SharedImageBuildId -> ByteString.ByteString-    encodeBuildId = LazyByteString.toStrict . Binary.encode--    rebuild-      :: Maybe ByteString.ByteString -> Action (RunResult SharedImageBuildId)-    rebuild mCurrentBIdBinary = do-      (_, act) <- getUserRuleOne nameQ (const Nothing) imgMatch-      act b9inv-      mNewBId <- getImgBuildId-      newBId  <- maybe-        (error-          (  "failed to get SharedImageBuildId for "-          ++ show nameQ-          ++ " in context of "-          ++ show b9inv-          )-        )-        return-        mNewBId-      let newBIdBinary = encodeBuildId newBId-      let change = if Just newBIdBinary == mCurrentBIdBinary-            then ChangedRecomputeSame-            else ChangedRecomputeDiff-      return $ RunResult change newBIdBinary newBId-     where-      imgMatch (SharedImageCustomActionRule name mkImage) =-        if name == nameQ then Just mkImage else Nothing+    go :: BuiltinRun SharedImageName SharedImageBuildId+    go nameQ mOldBIdBinary dependenciesChanged = do+      mCurrentBId <- getImgBuildId+      case mCurrentBId of+        Just currentBId ->+          let currentBIdBinary = encodeBuildId currentBId+           in if dependenciesChanged == RunDependenciesChanged && mOldBIdBinary == Just currentBIdBinary+                then return $ RunResult ChangedNothing currentBIdBinary currentBId+                else rebuild (Just currentBIdBinary)+        _ -> rebuild Nothing+      where+        getImgBuildId = liftIO (runB9ConfigActionWithOverrides (runLookupLocalSharedImage nameQ) b9inv)+        encodeBuildId :: SharedImageBuildId -> ByteString.ByteString+        encodeBuildId = LazyByteString.toStrict . Binary.encode+        rebuild :: Maybe ByteString.ByteString -> Action (RunResult SharedImageBuildId)+        rebuild mCurrentBIdBinary = do+          (_, act) <- getUserRuleOne nameQ (const Nothing) imgMatch+          act b9inv+          mNewBId <- getImgBuildId+          newBId <-+            maybe+              (error ("failed to get SharedImageBuildId for " ++ show nameQ ++ " in context of " ++ show b9inv))+              return+              mNewBId+          let newBIdBinary = encodeBuildId newBId+          let change =+                if Just newBIdBinary == mCurrentBIdBinary+                  then ChangedRecomputeSame+                  else ChangedRecomputeDiff+          return $ RunResult change newBIdBinary newBId+          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'.@@ -81,25 +70,20 @@ -- image identified by a 'SharedImageName'. -- NOTE: You must call 'enableSharedImageRules' before this action works. customSharedImageAction :: SharedImageName -> Action () -> Rules ()-customSharedImageAction b9img customAction = addUserRule-  (SharedImageCustomActionRule b9img customAction')- where-  customAction' b9inv = do-    customAction-    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+customSharedImageAction b9img customAction = addUserRule (SharedImageCustomActionRule b9img customAction')+  where+    customAction' b9inv = do+      customAction+      mCurrentBuildId <- liftIO (runB9ConfigActionWithOverrides (runLookupLocalSharedImage b9img) b9inv)+      putLoud (printf "Finished custom action, for %s, build-id is: %s" (show b9img) (show mCurrentBuildId))+      maybe (errorSharedImageNotFound b9img) return mCurrentBuildId  type instance RuleResult SharedImageName = SharedImageBuildId  data SharedImageCustomActionRule =-  SharedImageCustomActionRule SharedImageName (B9ConfigOverride -> Action SharedImageBuildId)-  deriving Typeable+  SharedImageCustomActionRule SharedImageName+                              (B9ConfigOverride -> Action SharedImageBuildId)+  deriving (Typeable)  errorSharedImageNotFound :: Monad m => SharedImageName -> m a errorSharedImageNotFound = fail . printf "Error: %s not found." . show

@@ -5,17 +5,20 @@ module B9.Vm   ( VmScript(..)   , substVmScript-  ) where+  )+where  import           Control.Parallel.Strategies+import           Control.Eff import           Data.Binary import           Data.Data-import           Data.Generics.Aliases       hiding (Generic)+import           Data.Generics.Aliases   hiding ( Generic ) import           Data.Generics.Schemes import           Data.Hashable-import           GHC.Generics                (Generic)+import           GHC.Generics                   ( Generic )  import           B9.Environment+import           B9.B9Error import           B9.Artifact.Content.StringTemplate import           B9.DiskImages import           B9.ExecEnv@@ -36,18 +39,26 @@  instance NFData VmScript -substVmScript :: Environment -> VmScript -> VmScript-substVmScript env = everywhere gsubst-  where-    gsubst :: Data a => a -> a-    gsubst = mkT substMountPoint `extT` substSharedDir `extT` substScript-    substMountPoint NotMounted     = NotMounted-    substMountPoint (MountPoint x) = MountPoint (sub x)-    substSharedDir (SharedDirectory fp mp)   = SharedDirectory (sub fp) mp-    substSharedDir (SharedDirectoryRO fp mp) = SharedDirectoryRO (sub fp) mp-    substSharedDir s                         = s-    substScript (In fp s)     = In (sub fp) s-    substScript (Run fp args) = Run (sub fp) (map sub args)-    substScript (As fp s)     = As (sub fp) s-    substScript s             = s-    sub = subst env+substVmScript+  :: forall e+   . (Member EnvironmentReader e, Member ExcB9 e)+  => VmScript+  -> Eff e VmScript+substVmScript = everywhereM gsubst+ where+  gsubst :: GenericM (Eff e)+  gsubst = mkM substMountPoint `extM` substSharedDir `extM` substScript++  substMountPoint NotMounted     = pure NotMounted+  substMountPoint (MountPoint x) = MountPoint <$> subst x++  substSharedDir (SharedDirectory fp mp) =+    SharedDirectory <$> subst fp <*> pure mp+  substSharedDir (SharedDirectoryRO fp mp) =+    SharedDirectoryRO <$> subst fp <*> pure mp+  substSharedDir s = pure s++  substScript (In  fp s   ) = In <$> subst fp <*> pure s+  substScript (Run fp args) = Run <$> subst fp <*> mapM subst args+  substScript (As  fp s   ) = As <$> subst fp <*> pure s+  substScript s             = pure s

@@ -1,26 +1,30 @@ {-| Effectful functions to execute and build virtual machine images using     an execution environment like e.g. libvirt-lxc. -}-module B9.VmBuilder (buildWithVm) where+module B9.VmBuilder+  ( buildWithVm+  ) where -import Data.List+import Control.Eff import Control.Monad import Control.Monad.IO.Class-import System.Directory (createDirectoryIfMissing, canonicalizePath)-import Text.Printf ( printf )+import Data.List+import System.Directory (canonicalizePath, createDirectoryIfMissing)+import Text.Printf (printf) import Text.Show.Pretty (ppShow) +import B9.Artifact.Readable+import B9.B9Config+import B9.B9Logging import B9.B9Monad-import B9.DiskImages+import B9.BuildInfo import B9.DiskImageBuilder+import B9.DiskImages import B9.ExecEnv-import B9.B9Config-import B9.Vm-import B9.Artifact.Readable-import B9.ShellScript import qualified B9.LibVirtLXC as LXC-+import B9.ShellScript+import B9.Vm -buildWithVm :: InstanceId -> [ImageTarget] -> FilePath -> VmScript -> B9 Bool+buildWithVm :: IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool buildWithVm iid imageTargets instanceDir vmScript = do   vmBuildSupportedImageTypes <- getVmScriptSupportedImageTypes vmScript   buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes@@ -28,15 +32,14 @@   when success (createDestinationImages buildImages imageTargets)   return success -getVmScriptSupportedImageTypes :: VmScript -> B9 [ImageType]-getVmScriptSupportedImageTypes NoVmScript =-  return [QCow2, Raw, Vmdk]+getVmScriptSupportedImageTypes :: IsB9 e => VmScript -> Eff e [ImageType]+getVmScriptSupportedImageTypes NoVmScript = return [QCow2, Raw, Vmdk] getVmScriptSupportedImageTypes _ = supportedImageTypes <$> getExecEnvType  supportedImageTypes :: ExecEnvType -> [ImageType] supportedImageTypes LibVirtLXC = LXC.supportedImageTypes -createBuildImages :: [ImageTarget] -> [ImageType] -> B9 [Image]+createBuildImages :: IsB9 e => [ImageTarget] -> [ImageType] -> Eff e [Image] createBuildImages imageTargets vmBuildSupportedImageTypes = do   dbgL "creating build images"   traceL (ppShow imageTargets)@@ -48,24 +51,22 @@     createBuildImage (ImageTarget dest imageSource _mnt) = do       buildDir <- getBuildDir       destTypes <- preferredDestImageTypes imageSource-      let buildImgType = head (destTypes-                               `intersect`-                               preferredSourceImageTypes dest-                               `intersect`-                               vmBuildSupportedImageTypes)+      let buildImgType =+            head (destTypes `intersect` preferredSourceImageTypes dest `intersect` vmBuildSupportedImageTypes)       srcImg <- resolveImageSource imageSource-      let buildImg = changeImageFormat buildImgType-                                       (changeImageDirectory buildDir srcImg)+      let buildImg = changeImageFormat buildImgType (changeImageDirectory buildDir srcImg)       buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg       materializeImageSource imageSource buildImg       return buildImgAbsolutePath -runVmScript :: InstanceId-            -> [ImageTarget]-            -> [Image]-            -> FilePath-            -> VmScript-            -> B9 Bool+runVmScript ::+     forall e. IsB9 e+  => InstanceId+  -> [ImageTarget]+  -> [Image]+  -> FilePath+  -> VmScript+  -> Eff e Bool runVmScript _ _ _ _ NoVmScript = return True runVmScript (IID iid) imageTargets buildImages instanceDir vmScript = do   dbgL (printf "starting vm script with instanceDir '%s'" instanceDir)@@ -78,17 +79,14 @@     else errorL "BUILD SCRIPT FAILED"   return success   where-    setUpExecEnv :: B9 ExecEnv+    setUpExecEnv :: IsB9 e => Eff e ExecEnv     setUpExecEnv = do       let (VmScript cpu shares _) = vmScript       let mountedImages = buildImages `zip` (itImageMountPoint <$> imageTargets)       sharesAbs <- createSharedDirs instanceDir shares-      return (ExecEnv iid-                      mountedImages-                      sharesAbs-                      (Resources AutomaticRamSize 8 cpu))+      return (ExecEnv iid mountedImages sharesAbs (Resources AutomaticRamSize 8 cpu)) -createSharedDirs :: FilePath -> [SharedDirectory] -> B9 [SharedDirectory]+createSharedDirs :: IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory] createSharedDirs instanceDir = mapM createSharedDir   where     createSharedDir (SharedDirectoryRO d m) = do@@ -100,11 +98,12 @@     createSharedDir (SharedSources mp) = do       d' <- createAndCanonicalize instanceDir       return $ SharedDirectoryRO d' mp-    createAndCanonicalize d = liftIO $ do-      createDirectoryIfMissing True d-      canonicalizePath d+    createAndCanonicalize d =+      liftIO $ do+        createDirectoryIfMissing True d+        canonicalizePath d -createDestinationImages :: [Image] -> [ImageTarget] -> B9 ()+createDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e () createDestinationImages buildImages imageTargets = do   dbgL "converting build- to output images"   let pairsToConvert = buildImages `zip` (itImageDestination `map` imageTargets)@@ -112,8 +111,8 @@   mapM_ (uncurry createDestinationImage) pairsToConvert   infoL "CONVERTED BUILD- TO OUTPUT IMAGES" -runInEnvironment :: ExecEnv -> Script -> B9 Bool+runInEnvironment :: IsB9 e => ExecEnv -> Script -> Eff e Bool runInEnvironment env script = do   t <- getExecEnvType   case t of-   LibVirtLXC -> LXC.runInEnvironment env script+    LibVirtLXC -> LXC.runInEnvironment env script

@@ -1,135 +1,102 @@-module B9.ArtifactGeneratorImplSpec (spec) where-import Test.Hspec-import Data.Text ()+module B9.ArtifactGeneratorImplSpec+  ( spec+  ) where -import B9.Artifact.Readable-import B9.Artifact.Readable.Interpreter-import B9.Environment as Env-import B9.DiskImages-import B9.ExecEnv-import B9.Vm-import B9.ShellScript+import           B9.Artifact.Readable+import           B9.Artifact.Readable.Interpreter+import           B9.DiskImages+import           B9.ExecEnv+import           B9.ShellScript+import           B9.Vm+import           Data.Text                        ()+import           Test.Hspec  spec :: Spec spec =   describe "assemble" $ do--     it "replaces '$...' variables in SourceImage Image file paths" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript-           expected = transientCOW "value" ""-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in SourceImage Image file paths" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [transientCOW "${variable}" ""] NoVmScript]+          expected = transientCOW "value" ""+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in SourceImage 'From' names" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript-           expected = transientShared "value" ""-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in SourceImage 'From' names" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [transientShared "${variable}" ""] NoVmScript]+          expected = transientShared "value" ""+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in the name of a shared image" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript-           expected = shareCOW "value" ""-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in the name of a shared image" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [shareCOW "${variable}" ""] NoVmScript]+          expected = shareCOW "value" ""+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in the name and path of a live installer image" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [liveInstallerCOWImage "${variable}" ""] NoVmScript-           expected = liveInstallerCOWImage "value" ""-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in the name and path of a live installer image" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [liveInstallerCOWImage "${variable}" ""] NoVmScript]+          expected = liveInstallerCOWImage "value" ""+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in the file name of an image exported as LocalFile" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript-           expected = localCOWImage "value" ""-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in the file name of an image exported as LocalFile" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [localCOWImage "${variable}" ""] NoVmScript]+          expected = localCOWImage "value" ""+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in mount point of an image" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript-           expected = localCOWImage "" "value"-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [actual] _))) = execIGEnv igEnv+    it "replaces '$...' variables in mount point of an image" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [localCOWImage "" "${variable}"] NoVmScript]+          expected = localCOWImage "" "value"+          (Right [IG _ _ (VmImages [actual] _)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in shared directory source and mount point (RO)" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")-           expected = emptyScriptWithSharedDirRO "value"-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+    it "replaces '$...' variables in shared directory source and mount point (RO)" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [] (emptyScriptWithSharedDirRO "${variable}")]+          expected = emptyScriptWithSharedDirRO "value"+          (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in shared directory source and mount point (RW)" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")-           expected = emptyScriptWithSharedDirRW "value"-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+    it "replaces '$...' variables in shared directory source and mount point (RW)" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [] (emptyScriptWithSharedDirRW "${variable}")]+          expected = emptyScriptWithSharedDirRW "value"+          (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected--     it "replaces '$...' variables in VmImages build script instructions" $-       let e = CGEnv (Env.fromStringPairs [("variable","value")]) []-           src = vmImagesArtifact "" [] (buildScript "${variable}")-           expected = buildScript "value"-           (Right [igEnv]) = execCGParser (parseArtifactGenerator src) e-           (Right (IG _ _ (VmImages [] actual))) = execIGEnv igEnv+    it "replaces '$...' variables in VmImages build script instructions" $+      let src = Let [("variable", "value")] [vmImagesArtifact "" [] (buildScript "${variable}")]+          expected = buildScript "value"+          (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src        in actual `shouldBe` expected  transientCOW :: FilePath -> FilePath -> ImageTarget transientCOW fileName mountPoint =-  ImageTarget Transient-              (CopyOnWrite (Image fileName QCow2 Ext4))-              (MountPoint mountPoint)+  ImageTarget Transient (CopyOnWrite (Image fileName QCow2 Ext4)) (MountPoint mountPoint)  transientShared :: FilePath -> FilePath -> ImageTarget-transientShared name mountPoint =-  ImageTarget Transient-              (From name KeepSize)-              (MountPoint mountPoint)+transientShared name mountPoint = ImageTarget Transient (From name KeepSize) (MountPoint mountPoint)  shareCOW :: FilePath -> FilePath -> ImageTarget shareCOW destName mountPoint =-  ImageTarget (Share destName QCow2 KeepSize)-              (CopyOnWrite (Image "cowSource" QCow2 Ext4))-              (MountPoint mountPoint)+  ImageTarget (Share destName QCow2 KeepSize) (CopyOnWrite (Image "cowSource" QCow2 Ext4)) (MountPoint mountPoint)  liveInstallerCOWImage :: FilePath -> FilePath -> ImageTarget liveInstallerCOWImage destName mountPoint =-  ImageTarget (LiveInstallerImage destName destName KeepSize)-              (CopyOnWrite (Image "cowSource" QCow2 Ext4))-              (MountPoint mountPoint)+  ImageTarget+    (LiveInstallerImage destName destName KeepSize)+    (CopyOnWrite (Image "cowSource" QCow2 Ext4))+    (MountPoint mountPoint)  localCOWImage :: FilePath -> FilePath -> ImageTarget localCOWImage destName mountPoint =-  ImageTarget (LocalFile (Image destName QCow2 Ext4) KeepSize)-              (CopyOnWrite (Image "cowSource" QCow2 Ext4))-              (MountPoint mountPoint)+  ImageTarget+    (LocalFile (Image destName QCow2 Ext4) KeepSize)+    (CopyOnWrite (Image "cowSource" QCow2 Ext4))+    (MountPoint mountPoint)  vmImagesArtifact :: String -> [ImageTarget] -> VmScript -> ArtifactGenerator-vmImagesArtifact iid imgs script =-  Artifact (IID iid) (VmImages imgs script)+vmImagesArtifact iid imgs script = Artifact (IID iid) (VmImages imgs script)  emptyScriptWithSharedDirRO :: String -> VmScript-emptyScriptWithSharedDirRO arg =-  VmScript X86_64 [SharedDirectoryRO arg (MountPoint arg) ] (Run "" [])+emptyScriptWithSharedDirRO arg = VmScript X86_64 [SharedDirectoryRO arg (MountPoint arg)] (Run "" [])  emptyScriptWithSharedDirRW :: String -> VmScript-emptyScriptWithSharedDirRW arg =-  VmScript X86_64 [SharedDirectory arg (MountPoint arg) ] (Run "" [])+emptyScriptWithSharedDirRW arg = VmScript X86_64 [SharedDirectory arg (MountPoint arg)] (Run "" [])  buildScript :: String -> VmScript buildScript arg =-  VmScript X86_64 [SharedDirectory arg (MountPoint arg),-                   SharedDirectoryRO arg NotMounted]-                  (As arg [In arg [Run arg [arg]]])+  VmScript+    X86_64+    [SharedDirectory arg (MountPoint arg), SharedDirectoryRO arg NotMounted]+    (As arg [In arg [Run arg [arg]]])