diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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`
-
-
diff --git a/b9.cabal b/b9.cabal
--- a/b9.cabal
+++ b/b9.cabal
@@ -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
diff --git a/src/cli/Main.hs b/src/cli/Main.hs
--- a/src/cli/Main.hs
+++ b/src/cli/Main.hs
@@ -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 =
diff --git a/src/lib/B9.hs b/src/lib/B9.hs
--- a/src/lib/B9.hs
+++ b/src/lib/B9.hs
@@ -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'
diff --git a/src/lib/B9/Artifact/Content.hs b/src/lib/B9/Artifact/Content.hs
--- a/src/lib/B9/Artifact/Content.hs
+++ b/src/lib/B9/Artifact/Content.hs
@@ -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
diff --git a/src/lib/B9/Artifact/Content/AST.hs b/src/lib/B9/Artifact/Content/AST.hs
--- a/src/lib/B9/Artifact/Content/AST.hs
+++ b/src/lib/B9/Artifact/Content/AST.hs
@@ -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
+ ]
diff --git a/src/lib/B9/Artifact/Content/Readable.hs b/src/lib/B9/Artifact/Content/Readable.hs
--- a/src/lib/B9/Artifact/Content/Readable.hs
+++ b/src/lib/B9/Artifact/Content/Readable.hs
@@ -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)
diff --git a/src/lib/B9/Artifact/Content/StringTemplate.hs b/src/lib/B9/Artifact/Content/StringTemplate.hs
--- a/src/lib/B9/Artifact/Content/StringTemplate.hs
+++ b/src/lib/B9/Artifact/Content/StringTemplate.hs
@@ -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
diff --git a/src/lib/B9/Artifact/Readable.hs b/src/lib/B9/Artifact/Readable.hs
--- a/src/lib/B9/Artifact/Readable.hs
+++ b/src/lib/B9/Artifact/Readable.hs
@@ -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.
diff --git a/src/lib/B9/Artifact/Readable/Interpreter.hs b/src/lib/B9/Artifact/Readable/Interpreter.hs
--- a/src/lib/B9/Artifact/Readable/Interpreter.hs
+++ b/src/lib/B9/Artifact/Readable/Interpreter.hs
@@ -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
diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs
--- a/src/lib/B9/B9Config.hs
+++ b/src/lib/B9/B9Config.hs
@@ -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
diff --git a/src/lib/B9/B9Config/LibVirtLXC.hs b/src/lib/B9/B9Config/LibVirtLXC.hs
--- a/src/lib/B9/B9Config/LibVirtLXC.hs
+++ b/src/lib/B9/B9Config/LibVirtLXC.hs
@@ -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
diff --git a/src/lib/B9/B9Config/Repository.hs b/src/lib/B9/B9Config/Repository.hs
--- a/src/lib/B9/B9Config/Repository.hs
+++ b/src/lib/B9/B9Config/Repository.hs
@@ -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.
diff --git a/src/lib/B9/B9Error.hs b/src/lib/B9/B9Error.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/B9Error.hs
@@ -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)
diff --git a/src/lib/B9/B9Exec.hs b/src/lib/B9/B9Exec.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/B9Exec.hs
@@ -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
diff --git a/src/lib/B9/B9Logging.hs b/src/lib/B9/B9Logging.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/B9Logging.hs
@@ -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 "
diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs
--- a/src/lib/B9/B9Monad.hs
+++ b/src/lib/B9/B9Monad.hs
@@ -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)
diff --git a/src/lib/B9/BuildInfo.hs b/src/lib/B9/BuildInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/BuildInfo.hs
@@ -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
diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs
--- a/src/lib/B9/DiskImageBuilder.hs
+++ b/src/lib/B9/DiskImageBuilder.hs
@@ -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
diff --git a/src/lib/B9/Environment.hs b/src/lib/B9/Environment.hs
--- a/src/lib/B9/Environment.hs
+++ b/src/lib/B9/Environment.hs
@@ -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
diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs
--- a/src/lib/B9/LibVirtLXC.hs
+++ b/src/lib/B9/LibVirtLXC.hs
@@ -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 =
- "\n "
- ++ buildId
- ++ "\n "
- ++ uuid
- ++ "\n "
- ++ memoryAmount cfg e
- ++ "\n "
- ++ memoryAmount cfg e
- ++ "\n "
- ++ cpuCountStr e
- ++ "\n \n \n "
- ++ renderGuestCapabilityEntries cfg
- ++ "\n \n \n \n exe\n "
- ++ scriptDirGuest
- initScript
- ++ "\n \n \n destroy\n restart\n destroy\n \n "
- ++ emulator cfg
- ++ "\n"
- ++ unlines
- ( libVirtNetwork (_networkId cfg)
- ++ (fsImage <$> envImageMounts e)
- ++ (fsSharedDir <$> envSharedDirectories e)
- )
- ++ "\n"
- ++ " \n \n \n \n \n \n \n \n\n"
+ "\n " ++
+ buildId ++
+ "\n " ++
+ uuid ++
+ "\n " ++
+ memoryAmount cfg e ++
+ "\n " ++
+ memoryAmount cfg e ++
+ "\n " ++
+ cpuCountStr e ++
+ "\n \n \n " ++
+ renderGuestCapabilityEntries cfg ++
+ "\n \n \n \n exe\n " ++
+ scriptDirGuest initScript ++
+ "\n \n \n destroy\n restart\n destroy\n \n " ++
+ emulator cfg ++
+ "\n" ++
+ unlines
+ (libVirtNetwork (_networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e)) ++
+ "\n" ++
+ " \n \n \n \n \n \n \n \n\n"
renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
renderGuestCapabilityEntries = unlines . map render . guestCapabilities
- where
- render :: LXCGuestCapability -> String
- render cap =
- let capStr = toLower <$> drop (length "CAP_") (show cap)
- in printf "<%s state='on'/>" capStr
+ where
+ render :: LXCGuestCapability -> String
+ render cap =
+ let capStr = toLower <$> drop (length "CAP_") (show cap)
+ in printf "<%s state='on'/>" capStr
osArch :: ExecEnv -> String
-osArch e = case cpuArch (envResources e) of
- X86_64 -> "x86_64"
- I386 -> "i686"
+osArch e =
+ case cpuArch (envResources e) of
+ X86_64 -> "x86_64"
+ I386 -> "i686"
libVirtNetwork :: Maybe String -> [String]
libVirtNetwork Nothing = []
-libVirtNetwork (Just n) =
- [ ""
- , " "
- , ""
- ]
+libVirtNetwork (Just n) = ["", " ", ""]
fsImage :: (Image, MountPoint) -> String
-fsImage (img, mnt) = case fsTarget mnt of
- Just mntXml ->
- "\n "
- ++ fsImgDriver img
- ++ "\n "
- ++ fsImgSource img
- ++ "\n "
- ++ mntXml
- ++ "\n"
- Nothing -> ""
- where
- fsImgDriver (Image _img fmt _fs) = printf "" driver fmt'
- where
- (driver, fmt') = case fmt of
- Raw -> ("type='loop'", "format='raw'")
- QCow2 -> ("type='nbd'", "format='qcow2'")
- Vmdk -> ("type='nbd'", "format='vmdk'")
-
- fsImgSource (Image src _fmt _fs) = ""
+fsImage (img, mnt) =
+ case fsTarget mnt of
+ Just mntXml ->
+ "\n " ++
+ fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++ "\n"
+ Nothing -> ""
+ where
+ fsImgDriver (Image _img fmt _fs) = printf "" driver fmt'
+ where
+ (driver, fmt') =
+ case fmt of
+ Raw -> ("type='loop'", "format='raw'")
+ QCow2 -> ("type='nbd'", "format='qcow2'")
+ Vmdk -> ("type='nbd'", "format='vmdk'")
+ fsImgSource (Image src _fmt _fs) = ""
fsSharedDir :: SharedDirectory -> String
-fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of
- Just mntXml ->
- "\n "
- ++ ""
- ++ "\n "
- ++ mntXml
- ++ "\n"
- Nothing -> ""
-fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of
- Just mntXml ->
- "\n "
- ++ ""
- ++ "\n "
- ++ mntXml
- ++ "\n \n"
- Nothing -> ""
+fsSharedDir (SharedDirectory hostDir mnt) =
+ case fsTarget mnt of
+ Just mntXml ->
+ "\n " ++ "" ++ "\n " ++ mntXml ++ "\n"
+ Nothing -> ""
+fsSharedDir (SharedDirectoryRO hostDir mnt) =
+ case fsTarget mnt of
+ Just mntXml ->
+ "\n " ++
+ "" ++ "\n " ++ mntXml ++ "\n \n"
+ Nothing -> ""
fsSharedDir (SharedSources _) = error "Unreachable code reached!"
fsTarget :: MountPoint -> Maybe String
fsTarget (MountPoint dir) = Just $ ""
-fsTarget _ = Nothing
+fsTarget _ = Nothing
memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String
memoryUnit cfg = toUnit . maxMemory . envResources
- where
- toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
- toUnit (RamSize _ u) = case u of
- GB -> "GiB"
- MB -> "MiB"
- KB -> "KiB"
- B -> "B"
+ where
+ toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
+ toUnit (RamSize _ u) =
+ case u of
+ GB -> "GiB"
+ MB -> "MiB"
+ KB -> "KiB"
+ B -> "B"
+
memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String
memoryAmount cfg = show . toAmount . maxMemory . envResources
- where
- toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
- toAmount (RamSize n _) = n
+ where
+ toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
+ toAmount (RamSize n _) = n
cpuCountStr :: ExecEnv -> String
cpuCountStr = show . cpuCount . envResources
diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs
--- a/src/lib/B9/Repository.hs
+++ b/src/lib/B9/Repository.hs
@@ -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
diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs
--- a/src/lib/B9/RepositoryIO.hs
+++ b/src/lib/B9/RepositoryIO.hs
@@ -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
+ ]
diff --git a/src/lib/B9/Shake/Actions.hs b/src/lib/B9/Shake/Actions.hs
--- a/src/lib/B9/Shake/Actions.hs
+++ b/src/lib/B9/Shake/Actions.hs
@@ -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 -- (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]))))
diff --git a/src/lib/B9/Shake/SharedImageRules.hs b/src/lib/B9/Shake/SharedImageRules.hs
--- a/src/lib/B9/Shake/SharedImageRules.hs
+++ b/src/lib/B9/Shake/SharedImageRules.hs
@@ -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
diff --git a/src/lib/B9/Vm.hs b/src/lib/B9/Vm.hs
--- a/src/lib/B9/Vm.hs
+++ b/src/lib/B9/Vm.hs
@@ -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
diff --git a/src/lib/B9/VmBuilder.hs b/src/lib/B9/VmBuilder.hs
--- a/src/lib/B9/VmBuilder.hs
+++ b/src/lib/B9/VmBuilder.hs
@@ -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
diff --git a/src/tests/B9/ArtifactGeneratorImplSpec.hs b/src/tests/B9/ArtifactGeneratorImplSpec.hs
--- a/src/tests/B9/ArtifactGeneratorImplSpec.hs
+++ b/src/tests/B9/ArtifactGeneratorImplSpec.hs
@@ -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]]])