diff --git a/.travis.yml b/.travis.yml
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,32 +1,2 @@
-language: c
-
-sudo: false
-
-addons:
- apt:
- sources:
- - hvr-ghc
- packages:
- - ghc-8.4.4
- - genisoimage
-
-before_install:
- - mkdir -p ~/.local/bin
- - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
- - export PATH=~/.local/bin:/opt/ghc/$GHCVER/bin:$PATH
- - chmod a+x ~/.local/bin/stack
-
-install:
- - stack --no-terminal --skip-ghc-check setup
-
-script:
- - stack --no-terminal --skip-ghc-check build
- - stack --no-terminal --skip-ghc-check test
- - stack --no-terminal --skip-ghc-check haddock
-
-cache:
- directories:
- - ~/.stack
- - ~/.local
- - ~/.stack-work-cache
- apt: true
+language: nix
+script: nix-build release.nix
diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,25 @@
# Changelog for B9
+## 0.5.67
+
+* Iron out UTF-8 decoding issues
+
+ * Use `Data.Text` in more places
+
+ * Remove `ByteStringGenerator`
+
+ * Change `ToContentGenerator` to produce only (strict) `Data.Text.Text`s
+
+* Add `B9.Text` a module with conversion functions for different string types.
+
+* Add helper functions and type for Erlang parsing:
+
+ * `textToErlangAst`,
+
+ * `stringToErlangAst` and
+
+ * `ErlangAST`
+
## 0.5.66
* Fix the Nix package:
diff --git a/b9.cabal b/b9.cabal
--- a/b9.cabal
+++ b/b9.cabal
@@ -1,5 +1,6 @@
+cabal-version: 2.2
name: b9
-version: 0.5.66
+version: 0.5.67
synopsis: A tool and library for building virtual machine images.
@@ -60,13 +61,47 @@
, CONTRIBUTING.md
, CODE_OF_CONDUCT.md
, CHANGELOG.md
-cabal-version: 1.22
+common b9Deps
+ build-depends: base >= 4.10 && < 5
+ , bytestring >= 0.10.8
+ , directory >= 1.3
+ , extensible-effects >= 5 && < 6
+ , lens >= 4
+ , text >= 1.2
+
+common b9Extensions
+ default-extensions: ConstraintKinds
+ , CPP
+ , DataKinds
+ , DeriveDataTypeable
+ , DeriveFunctor
+ , DeriveGeneric
+ , ExplicitNamespaces
+ , FlexibleContexts
+ , GADTs
+ , GeneralizedNewtypeDeriving
+ , KindSignatures
+ , MonoLocalBinds
+ , MultiParamTypeClasses
+ , RankNTypes
+ , ScopedTypeVariables
+ , StandaloneDeriving
+ , TemplateHaskell
+ , TupleSections
+ , TypeFamilies
+ , TypeOperators
+ default-language: Haskell2010
+ ghc-options: -Wall
+ -fwarn-unused-binds -fno-warn-unused-do-bind
+
source-repository head
type: git
location: git://github.com/sheyll/b9-vm-image-builder.git
library
+ import: b9Extensions, b9Deps
+ hs-source-dirs: src/lib
exposed-modules: B9
, B9.Artifact
, B9.Artifact.Content
@@ -92,6 +127,7 @@
, B9.DiskImages
, B9.Environment
, B9.ExecEnv
+ , B9.Text
, B9.LibVirtLXC
, B9.MBR
, B9.PartitionTable
@@ -107,23 +143,18 @@
, Data.ConfigFile.B9Extras
, System.IO.B9Extras
other-modules: Paths_b9
- -- other-extensions:
+ autogen-modules: Paths_b9
build-depends: ConfigFile >= 1.1.4
, QuickCheck >= 2.5
, aeson >= 1.0
, async >= 2.1
- , base >= 4.8 && < 5
, base64-bytestring
, binary >= 0.8.3
- , bytestring >= 0.10.8
, conduit >= 1.2
, conduit-extra >= 1.1
- , directory >= 1.3
, exceptions >= 0.10
- , extensible-effects >= 5 && < 6
, filepath >= 1.4
, hashable >= 1.2
- , lens >= 4
, monad-control >= 1.0 && < 1.1
, mtl >= 2.2
, time >= 1.6
@@ -137,7 +168,6 @@
, syb >= 0.6
, tagged >= 0.8 && < 0.9
, template >= 0.2
- , text >= 1.2
, transformers >= 0.5
, unordered-containers >= 0.2.8
, vector >= 0.11
@@ -145,79 +175,32 @@
, bifunctors >= 5.4
, free >= 4.12
, boxes >= 0.1.4
- if !impl(ghc >= 8.0)
- build-depends: semigroups >= 0.18
- default-extensions: TupleSections
- , GeneralizedNewtypeDeriving
- , ConstraintKinds
- , DeriveDataTypeable
- , DeriveGeneric
- , RankNTypes
- , FlexibleContexts
- , GADTs
- , DataKinds
- , KindSignatures
- , TypeFamilies
- , DeriveFunctor
- , TemplateHaskell
- , StandaloneDeriving
- , ScopedTypeVariables
- , TypeOperators
- , MonoLocalBinds
- , MultiParamTypeClasses
- , CPP
- hs-source-dirs: src/lib
- default-language: Haskell2010
- ghc-options: -Wall
- -fwarn-unused-binds -fno-warn-unused-do-bind
-
executable b9c
+ import: b9Extensions, b9Deps
main-is: Main.hs
other-modules: Paths_b9
- -- other-extensions:
+ autogen-modules: Paths_b9
build-depends: b9
- , base >= 4.8 && < 5
- , directory >= 1.3
- , bytestring >= 0.10
, extensible-effects >= 5 && < 6
, optparse-applicative >= 0.13
- , lens >= 4
- , text >= 1.2
hs-source-dirs: src/cli
- default-language: Haskell2010
- default-extensions: TupleSections
- , GeneralizedNewtypeDeriving
- , DeriveDataTypeable
- , DeriveFunctor
- , DeriveGeneric
- , RankNTypes
- , FlexibleContexts
- , GADTs
- , DataKinds
- , KindSignatures
- , TypeFamilies
- , TemplateHaskell
- , CPP
- ghc-options: -threaded -with-rtsopts=-N -Wall
- -fwarn-unused-binds -fno-warn-unused-do-bind
test-suite spec
+ import: b9Extensions, b9Deps
type: exitcode-stdio-1.0
ghc-options: -Wall
hs-source-dirs: src/tests
- default-language: Haskell2010
main-is: Spec.hs
+ autogen-modules: Paths_b9
other-modules: B9.Content.ErlTermsSpec
, B9.Content.ErlangPropListSpec
, B9.Content.YamlObjectSpec
, B9.ArtifactGeneratorImplSpec
, B9.DiskImagesSpec
, Paths_b9
- build-depends: base >= 4.8 && < 5
- , b9
+ build-depends: b9
, binary >= 0.8 && < 0.9
- , extensible-effects >= 5 && < 6
, hspec
, hspec-expectations
, QuickCheck >= 2.5
@@ -225,17 +208,3 @@
, yaml >= 0.8
, vector >= 0.11
, unordered-containers >= 0.2
- , bytestring >= 0.10
- , text >= 1.2
- default-extensions: TupleSections
- , GeneralizedNewtypeDeriving
- , DeriveDataTypeable
- , RankNTypes
- , FlexibleContexts
- , GADTs
- , DataKinds
- , KindSignatures
- , TypeFamilies
- , DeriveFunctor
- , TemplateHaskell
- , CPP
diff --git a/src/cli/Main.hs b/src/cli/Main.hs
--- a/src/cli/Main.hs
+++ b/src/cli/Main.hs
@@ -1,12 +1,16 @@
module Main
( main
- ) where
+ )
+where
import B9
-import Control.Lens ((&), (.~), (^.))
-import qualified Data.Text.Lazy as LazyT
-import Options.Applicative hiding (action)
-import Options.Applicative.Help.Pretty hiding (())
+import Control.Lens ( (&)
+ , (.~)
+ , (^.)
+ )
+import Options.Applicative hiding ( action )
+import Options.Applicative.Help.Pretty
+ hiding ( () )
main :: IO ()
main = do
@@ -26,155 +30,258 @@
applyB9RunParameters :: B9RunParameters -> IO ()
applyB9RunParameters (B9RunParameters overrides act vars) =
let cfg =
- noB9ConfigOverride &
- customLibVirtNetwork .~ (overrides ^. customLibVirtNetwork) &
- maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath) &
- customEnvironment .~ vars
- in runB9ConfigActionWithOverrides act cfg
+ noB9ConfigOverride
+ & customLibVirtNetwork
+ .~ (overrides ^. customLibVirtNetwork)
+ & maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath)
+ & customEnvironment
+ .~ vars
+ in runB9ConfigActionWithOverrides act cfg
parseCommandLine :: IO B9RunParameters
-parseCommandLine =
- execParser
- (info
- (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))
- (fullDesc <>
- progDesc
- "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. 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)
+parseCommandLine = execParser
+ (info
+ (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars))
+ ( fullDesc
+ <> progDesc
+ "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. 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)
globals :: Parser B9ConfigOverride
globals =
- toGlobalOpts <$>
- optional
- (strOption
- (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <>
- metavar "FILENAME")) <*>
- switch (help "Log everything that happens to stdout" <> short 'v' <> long "verbose") <*>
- switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*>
- optional (strOption (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar "FILENAME")) <*>
- optional
- (strOption
- (help
- "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")) <*>
- switch (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir") <*>
- switch (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir") <*>
- optional
- (strOption
- (help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache" <>
- metavar "DIRECTORY")) <*>
- optional
- (strOption (help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID")) <*>
- optional
- (strOption
- (help
- ("Override the libvirt-lxc network setting.\nThe special value '" ++
- hostNetworkMagicValue ++ "' disables restricted container networking.") <>
- long "network" <>
- metavar "NETWORK_ID"))
- where
- toGlobalOpts ::
- Maybe FilePath
- -> Bool
- -> Bool
- -> Maybe FilePath
- -> Maybe FilePath
- -> Bool
- -> Bool
- -> Maybe FilePath
- -> Maybe String
- -> Maybe String
- -> B9ConfigOverride
- 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 & projectRoot .~ buildRoot &
- keepTempDirs .~ keep &
- uniqueBuildDirs .~ not predictableBuildDir &
- repository .~ repo &
- repositoryCache .~ (Path <$> mRepoCache)
- in B9ConfigOverride
- { _customB9ConfigPath = Path <$> cfg
- , _customB9Config = b9cfg
- , _customLibVirtNetwork =
- (\n ->
- if n == hostNetworkMagicValue
- then Nothing
- else Just n) <$>
- libvirtNet
- , _customEnvironment = mempty
- }
+ toGlobalOpts
+ <$> optional
+ (strOption
+ ( help "Path to user's b9-configuration (default: ~/.b9/b9.conf)"
+ <> short 'c'
+ <> long "configuration-file"
+ <> metavar "FILENAME"
+ )
+ )
+ <*> switch
+ (help "Log everything that happens to stdout" <> short 'v' <> long
+ "verbose"
+ )
+ <*> switch (help "Suppress non-error output" <> short 'q' <> long "quiet")
+ <*> optional
+ (strOption
+ (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar
+ "FILENAME"
+ )
+ )
+ <*> optional
+ (strOption
+ ( help
+ "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"
+ )
+ )
+ <*> switch
+ (help "Keep build directories after exit" <> short 'k' <> long
+ "keep-build-dir"
+ )
+ <*> switch
+ (help "Predictable build directory names" <> short 'u' <> long
+ "predictable-build-dir"
+ )
+ <*> optional
+ (strOption
+ ( help
+ "Cache directory for shared images, default: '~/.b9/repo-cache'"
+ <> long "repo-cache"
+ <> metavar "DIRECTORY"
+ )
+ )
+ <*> optional
+ (strOption
+ ( help "Remote repository to share image to"
+ <> short 'r'
+ <> long "repo"
+ <> metavar "REPOSITORY_ID"
+ )
+ )
+ <*> optional
+ (strOption
+ ( help
+ ("Override the libvirt-lxc network setting.\nThe special value '"
+ ++ hostNetworkMagicValue
+ ++ "' disables restricted container networking."
+ )
+ <> long "network"
+ <> metavar "NETWORK_ID"
+ )
+ )
+ where
+ toGlobalOpts
+ :: Maybe FilePath
+ -> Bool
+ -> Bool
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> Bool
+ -> Bool
+ -> Maybe FilePath
+ -> Maybe String
+ -> Maybe String
+ -> B9ConfigOverride
+ 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
+ & projectRoot
+ .~ buildRoot
+ & keepTempDirs
+ .~ keep
+ & uniqueBuildDirs
+ .~ not predictableBuildDir
+ & repository
+ .~ repo
+ & repositoryCache
+ .~ (Path <$> mRepoCache)
+ in
+ B9ConfigOverride
+ { _customB9ConfigPath = Path <$> cfg
+ , _customB9Config = b9cfg
+ , _customLibVirtNetwork =
+ (\n -> if n == hostNetworkMagicValue then Nothing else Just n)
+ <$> libvirtNet
+ , _customEnvironment = mempty
+ }
cmds :: Parser (B9ConfigAction ())
-cmds =
- subparser
- (command "version" (info (pure runShowVersion) (progDesc "Show program version and exit.")) <>
- command
+cmds = subparser
+ ( command
+ "version"
+ (info (pure runShowVersion) (progDesc "Show program version and exit."))
+ <> command
"build"
- (info
- (void . runBuildArtifacts <$> buildFileParser)
- (progDesc "Merge all build file and generate all artifacts.")) <>
- command
+ (info (void . runBuildArtifacts <$> buildFileParser)
+ (progDesc "Merge all build file and generate all artifacts.")
+ )
+ <> command
"run"
(info
- ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many (strArgument idm))
- (progDesc "Run a command on the lastest version of the specified shared image.")) <>
- command
+ ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many
+ (strArgument idm)
+ )
+ (progDesc
+ "Run a command on the lastest version of the specified shared image."
+ )
+ )
+ <> command
"push"
(info
- (runPush <$> sharedImageNameParser)
- (progDesc "Push the lastest shared image from cache to the selected remote repository.")) <>
- command
+ (runPush <$> sharedImageNameParser)
+ (progDesc
+ "Push the lastest shared image from cache to the selected remote repository."
+ )
+ )
+ <> command
"pull"
(info
- (runPull <$> optional sharedImageNameParser)
- (progDesc
- "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version.")) <>
- command
+ (runPull <$> optional sharedImageNameParser)
+ (progDesc
+ "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version."
+ )
+ )
+ <> command
"clean-local"
- (info (pure runGcLocalRepoCache) (progDesc "Remove old versions of shared images from the local cache.")) <>
- command
+ (info
+ (pure runGcLocalRepoCache)
+ (progDesc
+ "Remove old versions of shared images from the local cache."
+ )
+ )
+ <> command
"clean-remote"
(info
- (pure runGcRemoteRepoCache)
- (progDesc
- "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories.")) <>
- command "list" (info (pure (void runListSharedImages)) (progDesc "List shared images.")) <>
- command "add-repo" (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.")) <>
- command "reformat" (info (runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files.")))
+ (pure runGcRemoteRepoCache)
+ (progDesc
+ "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories."
+ )
+ )
+ <> command
+ "list"
+ (info (pure (void runListSharedImages))
+ (progDesc "List shared images.")
+ )
+ <> command
+ "add-repo"
+ (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.")
+ )
+ <> command
+ "reformat"
+ (info (runFormatBuildFiles <$> buildFileParser)
+ (progDesc "Re-Format all build files.")
+ )
+ )
buildFileParser :: Parser [FilePath]
-buildFileParser =
- helper <*>
- some
- (strOption
- (help "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <>
- short 'f' <>
- long "project-file" <>
- metavar "FILENAME" <>
- noArgError (ErrorMsg "No build file specified!")))
+buildFileParser = helper <*> some
+ (strOption
+ ( help
+ "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run."
+ <> short 'f'
+ <> long "project-file"
+ <> metavar "FILENAME"
+ <> noArgError (ErrorMsg "No build file specified!")
+ )
+ )
buildVars :: Parser Environment
-buildVars = flip addPositionalArguments mempty . fmap LazyT.pack <$> many (strArgument idm)
+buildVars = flip addPositionalArguments mempty <$> many (strArgument idm)
remoteRepoParser :: Parser RemoteRepo
remoteRepoParser =
- helper <*>
- (RemoteRepo <$> strArgument (help "The name of the remmote repository." <> metavar "NAME") <*>
- strArgument (help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY") <*>
- (SshPrivKey <$>
- strArgument (help "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE")) <*>
- (SshRemoteHost <$>
- ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>
- argument auto (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*>
- (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER")))
+ helper
+ <*> ( RemoteRepo
+ <$> strArgument
+ (help "The name of the remmote repository." <> metavar "NAME")
+ <*> strArgument
+ ( help "The (remote) repository root path."
+ <> metavar "REMOTE_DIRECTORY"
+ )
+ <*> (SshPrivKey <$> strArgument
+ ( help
+ "Path to the SSH private key file used for authorization."
+ <> metavar "SSH_PRIV_KEY_FILE"
+ )
+ )
+ <*> ( SshRemoteHost
+ <$> ( (,)
+ <$> strArgument
+ (help "Repo hostname or IP" <> metavar "HOST")
+ <*> argument
+ auto
+ ( help "SSH-Port number"
+ <> value 22
+ <> showDefault
+ <> metavar "PORT"
+ )
+ )
+ )
+ <*> ( SshRemoteUser
+ <$> strArgument (help "SSH-User to login" <> metavar "USER")
+ )
+ )
sharedImageNameParser :: Parser SharedImageName
-sharedImageNameParser = helper <*> (SharedImageName <$> strArgument (help "Shared image name" <> metavar "NAME"))
+sharedImageNameParser =
+ helper
+ <*> ( SharedImageName
+ <$> strArgument (help "Shared image name" <> metavar "NAME")
+ )
diff --git a/src/lib/B9.hs b/src/lib/B9.hs
--- a/src/lib/B9.hs
+++ b/src/lib/B9.hs
@@ -25,58 +25,83 @@
, runAddRepo
, runLookupLocalSharedImage
, module X
- ) where
+ )
+where
-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)
+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.Text 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
@@ -103,118 +128,130 @@
-- 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 :: 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
+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 :: 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))
+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 :: 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
+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 :: 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
+ 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 :: B9ConfigAction ()
-runGcRemoteRepoCache =
- localB9Config
- (keepTempDirs .~ False)
- (runB9
- (do repos <- getSelectedRepos
- cache <- getRepoCache
- mapM_ (cleanRemoteRepo cache) repos))
+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 :: 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)))
+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.
@@ -222,22 +259,28 @@
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 :: 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'
+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,22 +5,25 @@
--
-- @since 0.5.62
module B9.Artifact.Content
- ( ByteStringGenerator
+ ( ContentGenerator
, ToContentGenerator(..)
+ , Text
)
where
import B9.B9Monad
import Control.Eff
-import Data.ByteString.Lazy as Lazy
+import Data.Text ( Text )
+import GHC.Stack
--- | A 'B9' action that procuces a 'Lazy.ByteString'.
+-- | A 'B9' action that procuces a 'Text'.
--
-- @since 0.5.62
-type ByteStringGenerator = B9 Lazy.ByteString
+type ContentGenerator = B9 Text
--- | Types whose values can be turned into a 'ContentGenerator'
+-- | Types whose values can be turned into an 'Eff'ect that produces
+-- 'Text', e.g. 'ContentGenerator'
--
-- @since 0.5.62
-class ToContentGenerator c a where
- toContentGenerator :: IsB9 e => c -> Eff e a
+class ToContentGenerator c where
+ toContentGenerator :: (HasCallStack, IsB9 e) => c -> Eff e Text
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
@@ -23,15 +23,13 @@
module B9.Artifact.Content.AST
( FromAST(..)
, AST(..)
- , decodeOrFail'
+ , parseFromTextWithErrorMessage
)
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.Data
import Data.Hashable
import GHC.Generics ( Generic )
@@ -40,18 +38,8 @@
import B9.Artifact.Content.StringTemplate
import B9.Artifact.Content
import B9.QCUtil
+import B9.Text
--- | Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@
--- 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
-- | Describe how to create structured content that has a tree-like syntactic
-- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines
@@ -95,7 +83,7 @@
-- | Types of values that describe content, that can be created from an 'AST'.
class FromAST a where
fromAST
- :: (IsB9 e, ToContentGenerator c Lazy.ByteString)
+ :: (IsB9 e, ToContentGenerator c)
=> AST c a -> Eff e a
instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where
diff --git a/src/lib/B9/Artifact/Content/CloudConfigYaml.hs b/src/lib/B9/Artifact/Content/CloudConfigYaml.hs
--- a/src/lib/B9/Artifact/Content/CloudConfigYaml.hs
+++ b/src/lib/B9/Artifact/Content/CloudConfigYaml.hs
@@ -14,20 +14,20 @@
module B9.Artifact.Content.CloudConfigYaml
( CloudConfigYaml(..)
, cloudConfigFileHeader
- ) where
+ )
+where
import B9.Artifact.Content.AST
import B9.Artifact.Content.YamlObject
-
-import Control.Parallel.Strategies (NFData)
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-import qualified Data.Binary.Get as Binary
-import qualified Data.ByteString.Lazy.Char8 as Lazy
-import Data.Data (Data, Typeable)
-import Data.Hashable (Hashable)
-import GHC.Generics (Generic)
-import Test.QuickCheck (Arbitrary)
+import B9.Text
+import Control.Parallel.Strategies ( NFData )
+import Data.Data ( Data
+ , Typeable
+ )
+import Data.Text as Text
+import Data.Hashable ( Hashable )
+import GHC.Generics ( Generic )
+import Test.QuickCheck ( Arbitrary )
-- | Cloud-init @meta-data@ configuration Yaml.
--
@@ -43,24 +43,22 @@
-- text file containing the cloud-config Yaml document.
--
-- @Since 0.5.62
-cloudConfigFileHeader :: Lazy.ByteString
+cloudConfigFileHeader :: Text
cloudConfigFileHeader = "#cloud-config\n"
instance FromAST CloudConfigYaml where
fromAST ast = MkCloudConfigYaml <$> fromAST (fromCloudConfigYaml <$> ast)
-instance Binary CloudConfigYaml where
- get
- -- skip the optional header line
- = do
- Binary.lookAheadM
- (do completeDocument <- Binary.lookAhead Binary.getRemainingLazyByteString
- if Lazy.length completeDocument >= Lazy.length cloudConfigFileHeader &&
- Lazy.take (Lazy.length cloudConfigFileHeader) completeDocument == cloudConfigFileHeader
- then do Binary.skip (fromIntegral (Lazy.length cloudConfigFileHeader))
- return (Just ())
- else return Nothing)
- MkCloudConfigYaml <$> Binary.get
- put (MkCloudConfigYaml y) = do
- Binary.put cloudConfigFileHeader
- Binary.put y
+instance Textual CloudConfigYaml where
+ parseFromText txt = do
+-- skip the optional header line
+ let header = Text.take (Text.length cloudConfigFileHeader) txt
+ txt' = if header == cloudConfigFileHeader
+ then Text.drop (Text.length cloudConfigFileHeader) txt
+ else txt
+ y <- parseFromText txt'
+ return (MkCloudConfigYaml y)
+
+ renderToText (MkCloudConfigYaml y) = do
+ txt <- renderToText y
+ return (Text.unlines [cloudConfigFileHeader, txt])
diff --git a/src/lib/B9/Artifact/Content/ErlTerms.hs b/src/lib/B9/Artifact/Content/ErlTerms.hs
--- a/src/lib/B9/Artifact/Content/ErlTerms.hs
+++ b/src/lib/B9/Artifact/Content/ErlTerms.hs
@@ -1,34 +1,52 @@
{-| Erlang term parser and pretty printer. -}
-module B9.Artifact.Content.ErlTerms (parseErlTerm
- ,erlTermParser
- ,renderErlTerm
- ,SimpleErlangTerm(..)
- ,arbitraryErlSimpleAtom
- ,arbitraryErlString
- ,arbitraryErlNumber
- ,arbitraryErlNatural
- ,arbitraryErlFloat
- ,arbitraryErlNameChar) where
+module B9.Artifact.Content.ErlTerms
+ ( parseErlTerm
+ , erlTermParser
+ , renderErlTerm
+ , SimpleErlangTerm(..)
+ , arbitraryErlSimpleAtom
+ , arbitraryErlString
+ , arbitraryErlNumber
+ , arbitraryErlNatural
+ , arbitraryErlFloat
+ , arbitraryErlNameChar
+ )
+where
import Control.Parallel.Strategies
import Data.Binary
-import qualified Data.ByteString.Lazy.Char8 as Lazy
import Data.Data
import Data.Function
import Data.Hashable
-import GHC.Generics (Generic)
+import GHC.Generics ( Generic )
import Test.QuickCheck
-import Text.Parsec
- ((<|>), many, spaces, char, option, between, string, choice,
- octDigit, hexDigit, many1, noneOf, try, digit, anyChar, alphaNum,
- lower, parse)
-import Text.Parsec.ByteString.Lazy
+import Text.Parsec ( (<|>)
+ , many
+ , spaces
+ , char
+ , option
+ , between
+ , string
+ , choice
+ , octDigit
+ , hexDigit
+ , many1
+ , noneOf
+ , try
+ , digit
+ , anyChar
+ , alphaNum
+ , lower
+ , parse
+ )
+import Text.Parsec.Text
import Text.Show.Pretty
import Control.Monad
import Text.Printf
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
import B9.QCUtil
+import B9.Text
-- | Simplified Erlang term representation.
data SimpleErlangTerm
@@ -51,34 +69,38 @@
-- restricted to either empty binaries or binaries with a string. The input
-- encoding must be restricted to ascii compatible 8-bit characters
-- (e.g. latin-1 or UTF8).
-parseErlTerm :: String -> Lazy.ByteString -> Either String SimpleErlangTerm
+parseErlTerm :: String -> Text -> Either String SimpleErlangTerm
parseErlTerm src content =
either (Left . ppShow) Right (parse erlTermParser src content)
-- | Convert an abstract Erlang term to a pretty byte string preserving the
-- encoding.
-renderErlTerm :: SimpleErlangTerm -> Lazy.ByteString
-renderErlTerm s = Lazy.pack (PP.render (prettyPrintErlTerm s PP.<> PP.char '.'))
+renderErlTerm :: SimpleErlangTerm -> Text
+renderErlTerm s =
+ unsafeRenderToText (PP.render (prettyPrintErlTerm s PP.<> PP.char '.'))
prettyPrintErlTerm :: SimpleErlangTerm -> PP.Doc
-prettyPrintErlTerm (ErlString str) = PP.doubleQuotes (PP.text (toErlStringString str))
+prettyPrintErlTerm (ErlString str) =
+ PP.doubleQuotes (PP.text (toErlStringString str))
prettyPrintErlTerm (ErlNatural n) = PP.integer n
-prettyPrintErlTerm (ErlFloat f) = PP.double f
-prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)
-prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom
- where
- quotedAtom =
- case toErlAtomString a of
- "" -> "''"
- a'@(firstChar:rest)
- | firstChar `elem` ['a' .. 'z'] &&
- all (`elem` atomCharsThatDontNeedQuoting) rest -> a'
- a' -> "'" ++ a' ++ "'"
- atomCharsThatDontNeedQuoting =
- ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"
+prettyPrintErlTerm (ErlFloat f) = PP.double f
+prettyPrintErlTerm (ErlChar c) = PP.text ("$" ++ toErlAtomChar c)
+prettyPrintErlTerm (ErlAtom a) = PP.text quotedAtom
+ where
+ quotedAtom = case toErlAtomString a of
+ "" -> "''"
+ a'@(firstChar : rest)
+ | firstChar
+ `elem` ['a' .. 'z']
+ && all (`elem` atomCharsThatDontNeedQuoting) rest
+ -> a'
+ a' -> "'" ++ a' ++ "'"
+ atomCharsThatDontNeedQuoting =
+ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"
prettyPrintErlTerm (ErlBinary []) = PP.text "<<>>"
-prettyPrintErlTerm (ErlBinary b) = PP.text ("<<\"" ++ toErlStringString b ++ "\">>")
+prettyPrintErlTerm (ErlBinary b) =
+ PP.text ("<<\"" ++ toErlStringString b ++ "\">>")
prettyPrintErlTerm (ErlList xs) =
PP.brackets (PP.sep (PP.punctuate PP.comma (prettyPrintErlTerm <$> xs)))
prettyPrintErlTerm (ErlTuple xs) =
@@ -89,111 +111,114 @@
toErlStringChar :: Char -> String
toErlStringChar = (table !!) . fromEnum
- where
- table =
- [printf "\\x{%x}" c | c <- [0 .. (31 :: Int)]] ++
- (pure . toEnum <$> [32 .. 33]) ++
- ["\\\""] ++
- (pure . toEnum <$> [35 .. 91]) ++
- ["\\\\"] ++ (pure . toEnum <$> [93 .. 126]) ++ [printf "\\x{%x}" c | c <- [(127 :: Int) ..]]
+ where
+ table =
+ [ printf "\\x{%x}" c | c <- [0 .. (31 :: Int)] ]
+ ++ (pure . toEnum <$> [32 .. 33])
+ ++ ["\\\""]
+ ++ (pure . toEnum <$> [35 .. 91])
+ ++ ["\\\\"]
+ ++ (pure . toEnum <$> [93 .. 126])
+ ++ [ printf "\\x{%x}" c | c <- [(127 :: Int) ..] ]
toErlAtomString :: String -> String
toErlAtomString = join . map toErlAtomChar
toErlAtomChar :: Char -> String
toErlAtomChar = (table !!) . fromEnum
- where
- table =
- [printf "\\x{%x}" c | c <- [0 .. (31 :: Int)]] ++
- (pure . toEnum <$> [32 .. 38]) ++
- ["\\'"] ++
- (pure . toEnum <$> [40 .. 91]) ++
- ["\\\\"] ++ (pure . toEnum <$> [93 .. 126]) ++ [printf "\\x{%x}" c | c <- [(127 :: Int) ..]]
+ where
+ table =
+ [ printf "\\x{%x}" c | c <- [0 .. (31 :: Int)] ]
+ ++ (pure . toEnum <$> [32 .. 38])
+ ++ ["\\'"]
+ ++ (pure . toEnum <$> [40 .. 91])
+ ++ ["\\\\"]
+ ++ (pure . toEnum <$> [93 .. 126])
+ ++ [ printf "\\x{%x}" c | c <- [(127 :: Int) ..] ]
instance Arbitrary SimpleErlangTerm where
- arbitrary = oneof [sized aErlString
- ,sized aErlNatural
- ,sized aErlFloat
- ,sized aErlChar
- ,sized aErlAtomUnquoted
- ,sized aErlAtomQuoted
- ,sized aErlBinary
- ,sized aErlList
- ,sized aErlTuple
- ]
- where
- decrSize 0 = resize 0
- decrSize n = resize (n - 1)
- aErlString n =
- ErlString <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))
- aErlFloat n = do
- f <- decrSize n arbitrary :: Gen Float
- let d = fromRational (toRational f)
- return (ErlFloat d)
- aErlNatural n =
- ErlNatural <$> decrSize n arbitrary
- aErlChar n =
- ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))
- aErlAtomUnquoted n = do
- f <- choose ('a','z')
- rest <- decrSize n aErlNameString
- return (ErlAtom (f:rest))
- aErlAtomQuoted n = do
- cs <- decrSize n aParsableErlString
- return (ErlAtom ("'" ++ cs ++ "'"))
- aErlBinary n =
- ErlBinary <$> decrSize n (listOf (choose (toEnum 0,toEnum 255)))
- aParsableErlString = oneof [aErlNameString
- ,aErlEscapedCharString
- ,aErlControlCharString
- ,aErlOctalCharString
- ,aErlHexCharString]
- aErlNameString = listOf (elements (['a'..'z'] ++ ['A'..'Z']++ ['0'..'9']++"@_"))
- aErlEscapedCharString = elements (("\\"++) . pure <$> "0bdefnrstv\\\"\'")
- aErlControlCharString = elements (("\\^"++) . pure <$> (['a'..'z'] ++ ['A'..'Z']))
- aErlOctalCharString = do
- n <- choose (1,3)
- os <- vectorOf n (choose (0,7))
- return (join ("\\":(show <$> (os::[Int]))))
- aErlHexCharString =
- oneof [twoDigitHex,nDigitHex]
- where
- twoDigitHex = do
- d1 <- choose (0,15) :: Gen Int
- d2 <- choose (0,15) :: Gen Int
- return (printf "\\x%x%X" d1 d2)
- nDigitHex = do
- zs <- listOf (elements "0")
- v <- choose (0,255) :: Gen Int
- return (printf "\\x{%s%x}" zs v)
- aErlList n =
- ErlList <$> resize (n `div` 2) (listOf arbitrary)
- aErlTuple n =
- ErlTuple <$> resize (n `div` 2) (listOf arbitrary)
+ arbitrary = oneof
+ [ sized aErlString
+ , sized aErlNatural
+ , sized aErlFloat
+ , sized aErlChar
+ , sized aErlAtomUnquoted
+ , sized aErlAtomQuoted
+ , sized aErlBinary
+ , sized aErlList
+ , sized aErlTuple
+ ]
+ where
+ decrSize 0 = resize 0
+ decrSize n = resize (n - 1)
+ aErlString n =
+ ErlString <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))
+ aErlFloat n = do
+ f <- decrSize n arbitrary :: Gen Float
+ let d = fromRational (toRational f)
+ return (ErlFloat d)
+ aErlNatural n = ErlNatural <$> decrSize n arbitrary
+ aErlChar n = ErlChar <$> decrSize n (choose (toEnum 0, toEnum 255))
+ aErlAtomUnquoted n = do
+ f <- choose ('a', 'z')
+ rest <- decrSize n aErlNameString
+ return (ErlAtom (f : rest))
+ aErlAtomQuoted n = do
+ cs <- decrSize n aParsableErlString
+ return (ErlAtom ("'" ++ cs ++ "'"))
+ aErlBinary n =
+ ErlBinary <$> decrSize n (listOf (choose (toEnum 0, toEnum 255)))
+ aParsableErlString = oneof
+ [ aErlNameString
+ , aErlEscapedCharString
+ , aErlControlCharString
+ , aErlOctalCharString
+ , aErlHexCharString
+ ]
+ aErlNameString =
+ listOf (elements (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "@_"))
+ aErlEscapedCharString = elements (("\\" ++) . pure <$> "0bdefnrstv\\\"\'")
+ aErlControlCharString =
+ elements (("\\^" ++) . pure <$> (['a' .. 'z'] ++ ['A' .. 'Z']))
+ aErlOctalCharString = do
+ n <- choose (1, 3)
+ os <- vectorOf n (choose (0, 7))
+ return (join ("\\" : (show <$> (os :: [Int]))))
+ aErlHexCharString = oneof [twoDigitHex, nDigitHex]
+ where
+ twoDigitHex = do
+ d1 <- choose (0, 15) :: Gen Int
+ d2 <- choose (0, 15) :: Gen Int
+ return (printf "\\x%x%X" d1 d2)
+ nDigitHex = do
+ zs <- listOf (elements "0")
+ v <- choose (0, 255) :: Gen Int
+ return (printf "\\x{%s%x}" zs v)
+ aErlList n = ErlList <$> resize (n `div` 2) (listOf arbitrary)
+ aErlTuple n = ErlTuple <$> resize (n `div` 2) (listOf arbitrary)
erlTermParser :: Parser SimpleErlangTerm
erlTermParser = between spaces (char '.') erlExpressionParser
erlExpressionParser :: Parser SimpleErlangTerm
-erlExpressionParser = erlAtomParser
- <|> erlCharParser
- <|> erlStringParser
- <|> erlBinaryParser
- <|> erlListParser
- <|> erlTupleParser
- <|> try erlFloatParser
- <|> erlNaturalParser
+erlExpressionParser =
+ erlAtomParser
+ <|> erlCharParser
+ <|> erlStringParser
+ <|> erlBinaryParser
+ <|> erlListParser
+ <|> erlTupleParser
+ <|> try erlFloatParser
+ <|> erlNaturalParser
erlAtomParser :: Parser SimpleErlangTerm
erlAtomParser =
- ErlAtom <$>
- (between (char '\'')
- (char '\'')
- (many (erlCharEscaped <|> noneOf "'"))
- <|>
- ((:) <$> lower <*> many erlNameChar))
+ ErlAtom
+ <$> (between (char '\'') (char '\'') (many (erlCharEscaped <|> noneOf "'"))
+ <|> ((:) <$> lower <*> many erlNameChar)
+ )
erlNameChar :: Parser Char
erlNameChar = alphaNum <|> char '@' <|> char '_'
@@ -207,46 +232,51 @@
-- point value. Calculating by hand is complicated because of precision
-- issues.
sign <- option "" ((char '-' >> return "-") <|> (char '+' >> return ""))
- s1 <- many digit
+ s1 <- many digit
char '.'
s2 <- many1 digit
- e <- do expSym <- choice [char 'e', char 'E']
- expSign <- option "" ((char '-' >> return "-") <|> (char '+' >> return "+"))
- expAbs <- many1 digit
- return ([expSym] ++ expSign ++ expAbs)
+ e <-
+ do
+ expSym <- choice [char 'e', char 'E']
+ expSign <- option
+ ""
+ ((char '-' >> return "-") <|> (char '+' >> return "+"))
+ expAbs <- many1 digit
+ return ([expSym] ++ expSign ++ expAbs)
<|> return ""
return (ErlFloat (read (sign ++ s1 ++ "." ++ s2 ++ e)))
erlNaturalParser :: Parser SimpleErlangTerm
erlNaturalParser = do
sign <- signParser
- dec <- decimalLiteral
+ dec <- decimalLiteral
return $ ErlNatural $ sign * dec
signParser :: Parser Integer
-signParser =
- (char '-' >> return (-1))
- <|> (char '+' >> return 1)
- <|> return 1
+signParser = (char '-' >> return (-1)) <|> (char '+' >> return 1) <|> return 1
decimalLiteral :: Parser Integer
-decimalLiteral =
- foldr (\radix acc ->
- (try (string (show radix ++ "#"))
- >> calcBE (toInteger radix) <$> many1 (erlDigits radix))
- <|> acc)
- (calcBE 10 <$> many1 (erlDigits 10))
- [2..36]
- where
- calcBE a = foldl (\acc d -> a * acc + d) 0
- erlDigits k = choice (take k digitParsers)
- digitParsers =
- -- create parsers that consume/match '0' .. '9' and "aA" .. "zZ" and return 0 .. 35
- map (\(cs,v) -> choice (char <$> cs) >> return v)
- (((pure <$> ['0' .. '9']) ++ zipWith ((++) `on` pure)
- ['a' .. 'z']
- ['A' .. 'Z'])
- `zip` [0..])
+decimalLiteral = foldr
+ (\radix acc ->
+ (try (string (show radix ++ "#")) >> calcBE (toInteger radix) <$> many1
+ (erlDigits radix)
+ )
+ <|> acc
+ )
+ (calcBE 10 <$> many1 (erlDigits 10))
+ [2 .. 36]
+ where
+ calcBE a = foldl (\acc d -> a * acc + d) 0
+ erlDigits k = choice (take k digitParsers)
+ digitParsers =
+ -- create parsers that consume/match '0' .. '9' and "aA" .. "zZ" and return 0 .. 35
+ map
+ (\(cs, v) -> choice (char <$> cs) >> return v)
+ ( ( (pure <$> ['0' .. '9'])
+ ++ zipWith ((++) `on` pure) ['a' .. 'z'] ['A' .. 'Z']
+ )
+ `zip` [0 ..]
+ )
erlStringParser :: Parser SimpleErlangTerm
erlStringParser = do
@@ -258,52 +288,54 @@
erlCharEscaped :: Parser Char
erlCharEscaped =
char '\\'
- >> (do char '^'
- choice (zipWith escapedChar ccodes creplacements)
+ >> ( do
+ char '^'
+ choice (zipWith escapedChar ccodes creplacements)
- <|>
- do char 'x'
- do ds <- between (char '{') (char '}') (fmap hexVal <$> many1 hexDigit)
- let val = foldl (\acc v -> acc * 16 + v) 0 ds
- return (toEnum val)
- <|>
- do x1 <- hexVal <$> hexDigit
- x2 <- hexVal <$> hexDigit;
- return (toEnum ((x1*16)+x2))
+ <|> do
+ char 'x'
+ do
+ ds <- between (char '{')
+ (char '}')
+ (fmap hexVal <$> many1 hexDigit)
+ let val = foldl (\acc v -> acc * 16 + v) 0 ds
+ return (toEnum val)
+ <|> do
+ x1 <- hexVal <$> hexDigit
+ x2 <- hexVal <$> hexDigit
+ return (toEnum ((x1 * 16) + x2))
- <|>
- do o1 <- octVal <$> octDigit
- do o2 <- octVal <$> octDigit
- do o3 <- octVal <$> octDigit
- return (toEnum ((((o1*8)+o2)*8)+o3))
- <|> return (toEnum ((o1*8)+o2))
- <|> return (toEnum o1)
+ <|> do
+ o1 <- octVal <$> octDigit
+ do
+ o2 <- octVal <$> octDigit
+ do
+ o3 <- octVal <$> octDigit
+ return (toEnum ((((o1 * 8) + o2) * 8) + o3))
+ <|> return (toEnum ((o1 * 8) + o2))
+ <|> return (toEnum o1)
- <|>
- choice (zipWith escapedChar codes replacements))
- where
- escapedChar code replacement = char code >> return replacement
- codes =
- "0bdefnrstv\\\"'"
- replacements =
- "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"
- ccodes =
- ['a' .. 'z'] ++ ['A' .. 'Z']
- creplacements =
- cycle ['\^A' .. '\^Z']
- hexVal v | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')
- | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')
- | otherwise = fromEnum v - fromEnum '0'
- octVal = hexVal
+ <|> choice (zipWith escapedChar codes replacements)
+ )
+ where
+ escapedChar code replacement = char code >> return replacement
+ codes = "0bdefnrstv\\\"'"
+ replacements = "\NUL\b\DEL\ESC\f\n\r \t\v\\\"'"
+ ccodes = ['a' .. 'z'] ++ ['A' .. 'Z']
+ creplacements = cycle ['\^A' .. '\^Z']
+ hexVal v | v `elem` ['a' .. 'z'] = 0xA + (fromEnum v - fromEnum 'a')
+ | v `elem` ['A' .. 'Z'] = 0xA + (fromEnum v - fromEnum 'A')
+ | otherwise = fromEnum v - fromEnum '0'
+ octVal = hexVal
erlBinaryParser :: Parser SimpleErlangTerm
-erlBinaryParser =
- do string "<<"
- spaces
- ErlString str <- option (ErlString "") erlStringParser
- string ">>"
- spaces
- return (ErlBinary str)
+erlBinaryParser = do
+ string "<<"
+ spaces
+ ErlString str <- option (ErlString "") erlStringParser
+ string ">>"
+ spaces
+ return (ErlBinary str)
erlListParser :: Parser SimpleErlangTerm
erlListParser = ErlList <$> erlNestedParser (char '[') (char ']')
@@ -313,26 +345,24 @@
erlNestedParser :: Parser a -> Parser b -> Parser [SimpleErlangTerm]
erlNestedParser open close =
- between
- (open >> spaces)
- (close >> spaces)
- (commaSep erlExpressionParser)
+ between (open >> spaces) (close >> spaces) (commaSep erlExpressionParser)
commaSep :: Parser a -> Parser [a]
-commaSep p = do r <- p
- spaces
- rest <- option [] (char ',' >> spaces >> commaSep p)
- return (r:rest)
- <|> return []
+commaSep p =
+ do
+ r <- p
+ spaces
+ rest <- option [] (char ',' >> spaces >> commaSep p)
+ return (r : rest)
+ <|> return []
arbitraryErlSimpleAtom :: Gen SimpleErlangTerm
-arbitraryErlSimpleAtom = ErlAtom <$> ((:)
- <$> arbitraryLetterLower
- <*> listOf arbitraryErlNameChar)
+arbitraryErlSimpleAtom =
+ ErlAtom <$> ((:) <$> arbitraryLetterLower <*> listOf arbitraryErlNameChar)
arbitraryErlString :: Gen SimpleErlangTerm
-arbitraryErlString = ErlString <$> listOf (oneof [arbitraryLetter
- ,arbitraryDigit])
+arbitraryErlString =
+ ErlString <$> listOf (oneof [arbitraryLetter, arbitraryDigit])
arbitraryErlNumber :: Gen SimpleErlangTerm
arbitraryErlNumber = oneof [arbitraryErlNatural, arbitraryErlFloat]
@@ -344,7 +374,5 @@
arbitraryErlFloat = ErlFloat <$> arbitrary
arbitraryErlNameChar :: Gen Char
-arbitraryErlNameChar = oneof [arbitraryLetter
- ,arbitraryDigit
- ,pure '_'
- ,pure '@']
+arbitraryErlNameChar =
+ oneof [arbitraryLetter, arbitraryDigit, pure '_', pure '@']
diff --git a/src/lib/B9/Artifact/Content/ErlangPropList.hs b/src/lib/B9/Artifact/Content/ErlangPropList.hs
--- a/src/lib/B9/Artifact/Content/ErlangPropList.hs
+++ b/src/lib/B9/Artifact/Content/ErlangPropList.hs
@@ -1,11 +1,11 @@
{-| Allow reading, merging and writing Erlang terms. -}
module B9.Artifact.Content.ErlangPropList
( ErlangPropList(..)
+ , textToErlangAst
+ , stringToErlangAst
) where
import Control.Parallel.Strategies
-import Data.Binary as Binary
-import Data.Binary.Get as Binary
import Data.Data
import Data.Function
import Data.Hashable
@@ -13,8 +13,7 @@
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as E
+import qualified Data.Text as T
import GHC.Generics (Generic)
import Text.Printf
@@ -22,8 +21,7 @@
import B9.Artifact.Content.ErlTerms
import B9.Artifact.Content
import B9.Artifact.Content.StringTemplate
-
-import Data.Binary.Put (putLazyByteString)
+import B9.Text
import Test.QuickCheck
-- | A wrapper type around erlang terms with a Semigroup instance useful for
@@ -74,13 +72,12 @@
combine t1 (ErlList pl2) = ErlList ([t1] <> pl2)
combine t1 t2 = ErlList [t1, t2]
-instance Binary ErlangPropList where
- get = do
- str <- Binary.getRemainingLazyByteString
- case parseErlTerm "" str of
- Right t -> return (ErlangPropList t)
- Left e -> fail e
- put (ErlangPropList t) = putLazyByteString (renderErlTerm t)
+instance Textual ErlangPropList where
+ parseFromText txt = do
+ str <- parseFromText txt
+ t <- parseErlTerm "" str
+ return (ErlangPropList t)
+ renderToText (ErlangPropList t) = renderToText (renderErlTerm t)
instance FromAST ErlangPropList where
fromAST (AST a) = pure a
@@ -98,11 +95,30 @@
xs
fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s
fromAST (ASTInt i) = pure $ ErlangPropList $ ErlString (show i)
- fromAST (ASTEmbed c) = ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> toContentGenerator c
+ fromAST (ASTEmbed c) = ErlangPropList . ErlString . T.unpack <$> toContentGenerator c
fromAST (ASTMerge []) = error "ASTMerge MUST NOT be used with an empty list!"
fromAST (ASTMerge asts) = foldl1 (<>) <$> mapM fromAST asts
fromAST (ASTParse src@(Source _ srcPath)) = do
c <- readTemplateFile src
- case decodeOrFail' srcPath c of
+ case parseFromTextWithErrorMessage srcPath c of
Right s -> return s
Left e -> error (printf "could not parse erlang source file: '%s'\n%s\n" srcPath e)
+
+
+-- * Misc. utilities
+
+-- | Parse a text containing an @Erlang@ expression ending with a @.@ and Return
+-- an 'AST'.
+--
+-- @since 0.5.67
+textToErlangAst :: Text -> AST c ErlangPropList
+textToErlangAst txt = either (error . ((unsafeParseFromText txt ++ "\n: ") ++))
+ AST
+ (parseFromTextWithErrorMessage "textToErlangAst" txt)
+
+-- | Parse a string containing an @Erlang@ expression ending with a @.@ and Return
+-- an 'AST'.
+--
+-- @since 0.5.67
+stringToErlangAst :: String -> AST c ErlangPropList
+stringToErlangAst = textToErlangAst . unsafeRenderToText
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,28 +3,26 @@
-}
module B9.Artifact.Content.Readable where
-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
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Lazy.Char8 as Lazy
-import Data.Data
-import GHC.Generics (Generic)
-import System.Exit
-import System.Process
-import Test.QuickCheck
+import Control.Parallel.Strategies
+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 B9.Text
+import Control.Monad.IO.Class
+import qualified Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.Base64 as B64
+import Data.Data
+import GHC.Generics ( Generic )
+import System.Exit
+import System.Process
+import Test.QuickCheck
+import GHC.Stack
-- | This is content that can be 'read' via the generated 'Read' instance.
data Content
@@ -52,39 +50,52 @@
instance NFData Content
instance Arbitrary Content where
- arbitrary =
- oneof
- [ FromTextFile <$> smaller arbitrary
- , RenderBase64BinaryFile <$> smaller arbitrary
- , RenderErlang <$> smaller arbitrary
- , RenderYamlObject <$> smaller arbitrary
- , RenderCloudConfig <$> smaller arbitrary
- , FromString <$> smaller arbitrary
- , FromByteString . Lazy.pack <$> smaller arbitrary
- , RenderBase64Binary . Lazy.pack <$> smaller arbitrary
- , FromURL <$> smaller arbitrary
- ]
+ arbitrary = oneof
+ [ FromTextFile <$> smaller arbitrary
+ , RenderBase64BinaryFile <$> smaller arbitrary
+ , RenderErlang <$> smaller arbitrary
+ , RenderYamlObject <$> smaller arbitrary
+ , RenderCloudConfig <$> smaller arbitrary
+ , FromString <$> smaller arbitrary
+ , FromByteString . Lazy.pack <$> smaller arbitrary
+ , RenderBase64Binary . Lazy.pack <$> smaller arbitrary
+ , FromURL <$> smaller arbitrary
+ ]
-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
- toContentGenerator (FromTextFile s) = readTemplateFile s
+instance ToContentGenerator Content where
+ toContentGenerator (RenderErlang ast) = unsafeRenderToText <$> fromAST ast
+ toContentGenerator (RenderYamlObject ast) =
+ unsafeRenderToText <$> fromAST ast
+ toContentGenerator (RenderCloudConfig ast) =
+ unsafeRenderToText <$> fromAST ast
+ toContentGenerator (FromTextFile s) = readTemplateFile s
toContentGenerator (RenderBase64BinaryFile s) = readBinaryFileAsBase64 s
- where
- readBinaryFileAsBase64 :: MonadIO m => FilePath -> m Lazy.ByteString
- readBinaryFileAsBase64 f = Lazy.fromStrict . B64.encode <$> liftIO (Strict.readFile f)
- toContentGenerator (RenderBase64Binary b) = pure (Lazy.fromStrict $ B64.encode $ Lazy.toStrict b)
- toContentGenerator (FromString str) = pure (Lazy.pack str)
- toContentGenerator (FromByteString str) = pure str
+ where
+ readBinaryFileAsBase64 :: (HasCallStack, MonadIO m) => FilePath -> m Text
+ readBinaryFileAsBase64 f =
+ unsafeRenderToText . B64.encode <$> liftIO (Strict.readFile f)
+ toContentGenerator (RenderBase64Binary b) =
+ pure (unsafeRenderToText . B64.encode . Lazy.toStrict $ b)
+ toContentGenerator (FromString str) = pure (unsafeRenderToText str)
+ toContentGenerator (FromByteString str) =
+ pure (unsafeRenderToText . Lazy.toStrict $ str)
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)
+ traceL
+ ("Downloaded (truncated to first 4K): \n\n" ++ take 4096 out ++ "\n\n"
+ )
+ pure (unsafeRenderToText out)
else do
errorL ("Download failed: " ++ err)
liftIO (exitWith exitCode)
+
+-- ** Convenient Aliases
+
+-- | An 'ErlangPropList' 'AST' with 'Content'
+--
+-- @since 0.5.67
+type ErlangAst = AST Content ErlangPropList
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,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
{-| Utility functions based on 'Data.Text.Template' to offer @ $var @ variable
expansion in string throughout a B9 artifact.
@@ -9,6 +10,7 @@
-}
module B9.Artifact.Content.StringTemplate
( subst
+ , substStr
, substFile
, substPath
, readTemplateFile
@@ -27,16 +29,16 @@
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 ( Text )
+import qualified Data.Text.Lazy as LazyText
+ ( toStrict )
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
import Data.Text.Template ( renderA
, templateSafe
+ , Template
)
import GHC.Generics ( Generic )
import System.IO.B9Extras
@@ -70,7 +72,7 @@
readTemplateFile
:: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e)
=> SourceFile
- -> Eff e Lazy.ByteString
+ -> Eff e Text
readTemplateFile (Source conv f') = do
let
onErrorFileName e = error
@@ -80,8 +82,8 @@
f'
(displayException e)
)
- f <- subst f' `catchB9Error` onErrorFileName
- c <- liftIO (Lazy.readFile f)
+ f <- subst (Text.pack f') `catchB9Error` onErrorFileName
+ c <- liftIO (Text.readFile (Text.unpack f))
case conv of
NoConversion -> return c
ExpandVariables ->
@@ -91,54 +93,47 @@
f
(displayException e)
)
- in substEB c `catchB9Error` onErrorFile
+ in subst c `catchB9Error` onErrorFile
--- String template substitution via dollar
-subst :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
-subst templateStr = LazyT.unpack . LazyE.decodeUtf8 <$> substEB
- (LazyE.encodeUtf8 (LazyT.pack templateStr))
+-- | 'Text' template substitution.
+subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text
+subst templateStr = do
+ t <- templateSafeExcB9 templateStr
+ LazyText.toStrict <$> renderA t lookupOrThrow
--- String template substitution via dollar
-substEB
- :: (Member ExcB9 e, Member EnvironmentReader e)
- => Lazy.ByteString
- -> Eff e Lazy.ByteString
-substEB templateStr = do
- t <- template'
- 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)
+-- | 'String' template substitution
+substStr
+ :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
+substStr templateStr = do
+ t <- templateSafeExcB9 (Text.pack templateStr)
+ Text.unpack . LazyText.toStrict <$> renderA t lookupOrThrow
- 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
+templateSafeExcB9 :: Member ExcB9 e => Text -> Eff e Template
+templateSafeExcB9 templateStr = case templateSafe 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)
+ templatedText <- liftIO (Text.readFile src)
+ let t = templateSafe templatedText
case t of
Left (r, c) ->
- let badLine =
- unlines
- (take r (lines (StrictT.unpack (StrictE.decodeUtf8 templateBs))))
- colMarker = replicate (c - 1) '-' ++ "^"
+ let badLine = Text.unlines (take r (Text.lines templatedText))
+ colMarker = Text.replicate (c - 1) "-" <> "^"
in throwB9Error
(printf "Template error in file '%s' line %i:\n\n%s\n%s\n"
src
@@ -147,18 +142,17 @@
colMarker
)
Right template' -> do
- out <- LazyE.encodeUtf8
- <$> renderA template' (templateEnvLookupSrcFile src)
- liftIO (Lazy.writeFile dest out)
+ out <- renderA template' (templateEnvLookupSrcFile src)
+ liftIO (Text.writeFile dest (LazyText.toStrict out))
templateEnvLookupSrcFile
:: (Member EnvironmentReader e, Member ExcB9 e, MonadIO (Eff e))
=> FilePath
- -> StrictT.Text
- -> Eff e StrictT.Text
+ -> Text
+ -> Eff e Text
templateEnvLookupSrcFile src x = do
- r <- catchB9ErrorAsEither (lookupOrThrow (LazyT.fromStrict x))
- either err (pure . LazyT.toStrict) r
+ r <- catchB9ErrorAsEither (lookupOrThrow x)
+ either err pure r
where err e = throwB9Error (show e ++ "\nIn file: \'" ++ src ++ "\'\n")
@@ -167,10 +161,10 @@
=> 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
+ Path p -> Path <$> substStr p
+ InHomeDir p -> InHomeDir <$> substStr p
+ InB9UserDir p -> InB9UserDir <$> substStr p
+ InTempDir p -> InTempDir <$> substStr p
instance Arbitrary SourceFile where
arbitrary =
@@ -190,8 +184,8 @@
-> Eff e s
withSubstitutedStringBindings bs nested = do
let extend env (k, v) = localEnvironment (const env) $ do
- kv <- (k, ) <$> subst v
- addStringBinding kv env
+ kv <- (Text.pack k, ) <$> subst (Text.pack v)
+ addBinding kv env
env <- askEnvironment
envExt <- foldM extend env bs
localEnvironment (const envExt) nested
diff --git a/src/lib/B9/Artifact/Content/YamlObject.hs b/src/lib/B9/Artifact/Content/YamlObject.hs
--- a/src/lib/B9/Artifact/Content/YamlObject.hs
+++ b/src/lib/B9/Artifact/Content/YamlObject.hs
@@ -2,32 +2,32 @@
-- writing yaml files within B9.
module B9.Artifact.Content.YamlObject
( YamlObject(..)
- ) where
+ )
+where
+import B9.Text
import Control.Applicative
import Control.Parallel.Strategies
-import Data.Binary (Binary (..))
-import qualified Data.Binary.Get as Binary
-import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Control.Exception
+import Data.Bifunctor ( first )
+import qualified Data.ByteString.Lazy as Lazy
import Data.Data
import Data.Function
import Data.Hashable
-import Data.HashMap.Strict hiding (singleton)
+import Data.HashMap.Strict hiding ( singleton )
import Data.Semigroup
-import qualified Data.Text as StrictT
-import qualified Data.Text.Encoding as StrictE
-import qualified Data.Text.Lazy as LazyT
-import qualified Data.Text.Lazy.Encoding as LazyE
-import Data.Vector as Vector (singleton, (++))
-import Data.Yaml as Yaml
-import GHC.Generics (Generic)
-import Prelude hiding ((++))
+import Data.Vector as Vector
+ ( singleton
+ , (++)
+ )
+import Data.Yaml as Yaml
+import GHC.Generics ( Generic )
+import Prelude hiding ( (++) )
import Text.Printf
import B9.Artifact.Content
import B9.Artifact.Content.AST
import B9.Artifact.Content.StringTemplate
-
import Test.QuickCheck
-- | A wrapper type around yaml values with a Semigroup instance useful for
@@ -36,61 +36,72 @@
{ _fromYamlObject :: Yaml.Value
} deriving (Hashable, NFData, Eq, Data, Typeable, Generic)
-instance Binary YamlObject where
- put = put . encode . _fromYamlObject
- get = YamlObject . either (error . show) id . Yaml.decodeThrow . Lazy.toStrict <$> Binary.getRemainingLazyByteString
+instance Textual YamlObject where
+ renderToText = renderToText . encode . _fromYamlObject
+ parseFromText t = do
+ rb <- parseFromText t
+ y <- first displayException $ Yaml.decodeThrow (Lazy.toStrict rb)
+ return (YamlObject y)
+
instance Read YamlObject where
readsPrec _ = readsYamlObject
- where
- readsYamlObject :: ReadS YamlObject
- readsYamlObject s = [(yamlFromString y, r2) | ("YamlObject", r1) <- lex s, (y, r2) <- reads r1]
- where
- yamlFromString :: String -> YamlObject
- yamlFromString = either error id . decodeOrFail' "HERE-DOC" . LazyE.encodeUtf8 . LazyT.pack
+ where
+ readsYamlObject :: ReadS YamlObject
+ readsYamlObject s =
+ [ (yamlFromString y, r2)
+ | ("YamlObject", r1) <- lex s
+ , (y , r2) <- reads r1
+ ]
+ where
+ yamlFromString :: String -> YamlObject
+ yamlFromString =
+ either error id
+ . parseFromTextWithErrorMessage "HERE-DOC"
+ . unsafeRenderToText
instance Show YamlObject where
- show (YamlObject o) = "YamlObject " <> show (StrictT.unpack $ StrictE.decodeUtf8 $ encode o)
+ show (YamlObject o) = "YamlObject " <> show (unsafeRenderToText $ encode o)
instance Semigroup YamlObject where
(YamlObject v1) <> (YamlObject v2) = YamlObject (combine v1 v2)
- where
- combine :: Yaml.Value -> Yaml.Value -> Yaml.Value
- combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)
- combine (Array a1) (Array a2) = Array (a1 ++ a2)
- combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2)
- combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2)
- combine (String s1) (String s2) = String (s1 <> s2)
- combine t1 t2 = array [t1, t2]
+ where
+ combine :: Yaml.Value -> Yaml.Value -> Yaml.Value
+ combine (Object o1) (Object o2) = Object (unionWith combine o1 o2)
+ combine (Array a1) (Array a2) = Array (a1 ++ a2)
+ combine (Array a1) t2 = Array (a1 ++ Vector.singleton t2)
+ combine t1 (Array a2) = Array (Vector.singleton t1 ++ a2)
+ combine (String s1) (String s2) = String (s1 <> s2)
+ combine t1 t2 = array [t1, t2]
instance FromAST YamlObject where
- fromAST ast =
- case ast of
- ASTObj pairs -> do
- ys <- mapM fromASTPair pairs
- return (YamlObject (object ys))
- ASTArr asts -> do
- ys <- mapM fromAST asts
- let ys' = (\(YamlObject o) -> o) <$> ys
- return (YamlObject (array ys'))
- ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!"
- ASTMerge asts -> do
- ys <- mapM fromAST asts
- return (foldl1 (<>) ys)
- ASTEmbed c -> YamlObject . toJSON . StrictT.unpack . StrictE.decodeUtf8 . Lazy.toStrict <$> toContentGenerator c
- ASTString str -> return (YamlObject (toJSON str))
- ASTInt int -> return (YamlObject (toJSON int))
- ASTParse src@(Source _ srcPath) -> do
- c <- readTemplateFile src
- case decodeOrFail' srcPath c of
- Right s -> return s
- Left e -> error (printf "could not parse yaml source file: '%s'\n%s\n" srcPath e)
- AST a -> pure a
- where
- fromASTPair (key, value) = do
- (YamlObject o) <- fromAST value
- let key' = StrictT.pack key
- return $ key' .= o
+ fromAST ast = case ast of
+ ASTObj pairs -> do
+ ys <- mapM fromASTPair pairs
+ return (YamlObject (object ys))
+ ASTArr asts -> do
+ ys <- mapM fromAST asts
+ let ys' = (\(YamlObject o) -> o) <$> ys
+ return (YamlObject (array ys'))
+ ASTMerge [] -> error "ASTMerge MUST NOT be used with an empty list!"
+ ASTMerge asts -> do
+ ys <- mapM fromAST asts
+ return (foldl1 (<>) ys)
+ ASTEmbed c -> YamlObject . toJSON <$> toContentGenerator c
+ ASTString str -> return (YamlObject (toJSON str))
+ ASTInt int -> return (YamlObject (toJSON int))
+ ASTParse src@(Source _ srcPath) -> do
+ c <- readTemplateFile src
+ case parseFromTextWithErrorMessage srcPath c of
+ Right s -> return s
+ Left e -> error
+ (printf "could not parse yaml source file: '%s'\n%s\n" srcPath e)
+ AST a -> pure a
+ where
+ fromASTPair (key, value) = do
+ (YamlObject o) <- fromAST value
+ let key' = unsafeRenderToText key
+ return $ key' .= o
instance Arbitrary YamlObject where
arbitrary = pure (YamlObject Null)
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
@@ -19,15 +19,16 @@
-- ** Re-exports
, ArtifactSource(..)
, getArtifactSourceFiles
- ) where
+ )
+where
import Control.Parallel.Strategies
import Data.Binary
import Data.Data
import Data.Hashable
-import Data.Semigroup as Sem
-import GHC.Generics (Generic)
-import System.FilePath ((<.>))
+import Data.Semigroup as Sem
+import GHC.Generics ( Generic )
+import System.FilePath ( (<.>) )
import B9.Artifact.Readable.Source
import B9.DiskImages
@@ -133,12 +134,12 @@
instance NFData ArtifactGenerator
instance Sem.Semigroup ArtifactGenerator where
- (Let [] []) <> x = x
- x <> (Let [] []) = x
- x <> y = Let [] [x, y]
+ (Let [] []) <> x = x
+ x <> (Let [] []) = x
+ x <> y = Let [] [x, y]
instance Monoid ArtifactGenerator where
- mempty = Let [] []
+ mempty = Let [] []
mappend = (Sem.<>)
-- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all
@@ -234,43 +235,48 @@
-- | Return the files that the artifact assembly consist of.
getAssemblyOutput :: ArtifactAssembly -> [AssemblyOutput]
-getAssemblyOutput (VmImages ts _) = AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts
+getAssemblyOutput (VmImages ts _) =
+ AssemblyGeneratesOutputFiles . getImageDestinationOutputFiles <$> ts
getAssemblyOutput (CloudInit ts o) = getCloudInitOutputFiles o <$> ts
- where
- getCloudInitOutputFiles baseName t =
- case t of
- CI_ISO -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]
- CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]
- CI_DIR -> AssemblyCopiesSourcesToDirectory baseName
+ where
+ getCloudInitOutputFiles baseName t = case t of
+ CI_ISO -> AssemblyGeneratesOutputFiles [baseName <.> "iso"]
+ CI_VFAT -> AssemblyGeneratesOutputFiles [baseName <.> "vfat"]
+ CI_DIR -> AssemblyCopiesSourcesToDirectory baseName
-- * QuickCheck instances
instance Arbitrary ArtifactGenerator where
- arbitrary =
- oneof
- [ Sources <$> halfSize arbitrary <*> halfSize arbitrary
- , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary
- , halfSize arbitraryEachT <*> halfSize arbitrary
- , halfSize arbitraryEach <*> halfSize arbitrary
- , Artifact <$> smaller arbitrary <*> smaller arbitrary
- , pure EmptyArtifact
- ]
+ arbitrary = oneof
+ [ Sources <$> halfSize arbitrary <*> halfSize arbitrary
+ , Let <$> halfSize arbitraryEnv <*> halfSize arbitrary
+ , halfSize arbitraryEachT <*> halfSize arbitrary
+ , halfSize arbitraryEach <*> halfSize arbitrary
+ , Artifact <$> smaller arbitrary <*> smaller arbitrary
+ , pure EmptyArtifact
+ ]
arbitraryEachT :: Gen ([ArtifactGenerator] -> ArtifactGenerator)
-arbitraryEachT =
- sized $ \n ->
- EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*>
- oneof [listOf (vectorOf n (halfSize arbitrary)), listOf1 (listOf (halfSize arbitrary))]
+arbitraryEachT = sized $ \n ->
+ EachT <$> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))) <*> oneof
+ [ listOf (vectorOf n (halfSize arbitrary))
+ , listOf1 (listOf (halfSize arbitrary))
+ ]
arbitraryEach :: Gen ([ArtifactGenerator] -> ArtifactGenerator)
-arbitraryEach =
- sized $ \n ->
- Each <$> listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> vectorOf n (halfSize (listOf1 (choose ('a', 'z')))))
+arbitraryEach = sized $ \n -> Each <$> listOf
+ ((,) <$> listOf1 (choose ('a', 'z')) <*> vectorOf
+ n
+ (halfSize (listOf1 (choose ('a', 'z'))))
+ )
instance Arbitrary InstanceId where
arbitrary = IID <$> arbitraryFilePath
instance Arbitrary ArtifactAssembly where
- arbitrary = oneof [CloudInit <$> arbitrary <*> arbitraryFilePath, VmImages <$> smaller arbitrary <*> pure NoVmScript]
+ arbitrary = oneof
+ [ CloudInit <$> arbitrary <*> arbitraryFilePath
+ , VmImages <$> smaller arbitrary <*> pure NoVmScript
+ ]
instance Arbitrary CloudInitType where
arbitrary = elements [CI_ISO, CI_VFAT, CI_DIR]
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
@@ -10,42 +10,45 @@
, InstanceGenerator(..)
, runInstanceGenerator
, InstanceSources(..)
- ) where
+ )
+where
-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)
+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.Text
+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 Data.Data
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Data.List
+import Data.String
+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'.
@@ -60,21 +63,23 @@
-- | 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 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) =
+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 = textFileWriterOutputFile <$> sgs
- in (pd ) <$> sourceFiles
- in getAssemblyOutput a >>= toOutFile
+ in (pd ) <$> sourceFiles
+ in getAssemblyOutput a >>= toOutFile
-- | Run an artifact generator to produce the artifacts.
assemble :: ArtifactGenerator -> B9 [AssembledArtifact]
assemble artGen = do
b9cfgEnvVars <- askEnvironment
- buildId <- getBuildId
- buildDate <- getBuildDate
+ buildId <- getBuildId
+ buildDate <- getBuildDate
runArtifactSourcesReader (InstanceSources b9cfgEnvVars mempty) $ do
is <- evalArtifactGenerator buildId buildDate artGen
createAssembledArtifacts is
@@ -82,42 +87,58 @@
-- | 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))))
+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 ::
- (Member ExcB9 e, Member EnvironmentReader e)
+evalArtifactGenerator
+ :: (Member ExcB9 e, Member EnvironmentReader e)
=> String
-> String
-> ArtifactGenerator
- -> Eff (ArtifactSourcesReader ': e) [InstanceGenerator [TextFileWriter]]
+ -> 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)
+ [(buildDateKey, buildDate), (buildIdKey, buildId)]
+ (runArtifactInterpreter (interpretGenerator artGen))
+ `catchB9Error` ( throwB9Error
+ . printf "Failed to eval:\n%s\nError: %s" (ppShow artGen)
+ . displayException
+ )
type ArtifactSourcesReader = Reader [ArtifactSource]
-runArtifactSourcesReader ::
- Member EnvironmentReader e => InstanceSources -> Eff (ArtifactSourcesReader ': e) a -> Eff e a
-runArtifactSourcesReader x y = runReader (isSources x) (localEnvironment (const (isEnv x)) y)
+runArtifactSourcesReader
+ :: Member EnvironmentReader e
+ => InstanceSources
+ -> Eff (ArtifactSourcesReader ': e) a
+ -> Eff e a
+runArtifactSourcesReader x y =
+ runReader (isSources x) (localEnvironment (const (isEnv x)) y)
-- | Monad for creating Instance generators.
-type ArtifactInterpreter e = Writer [InstanceGenerator InstanceSources] : ArtifactSourcesReader : e
+type ArtifactInterpreter e
+ = Writer [InstanceGenerator InstanceSources] : ArtifactSourcesReader : e
-runArtifactInterpreter ::
- (Member ExcB9 e, Member EnvironmentReader e)
+runArtifactInterpreter
+ :: (Member ExcB9 e, Member EnvironmentReader e)
=> Eff (ArtifactInterpreter e) ()
-> Eff (ArtifactSourcesReader : e) [InstanceGenerator [TextFileWriter]]
runArtifactInterpreter ai = do
@@ -125,77 +146,96 @@
traverse toFileInstanceGenerator igs
-- | 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
- 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)))
+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
+ 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)
+ )
+ )
-interpretAssembly ::
- (Member ExcB9 e, Member EnvironmentReader e) => InstanceId -> ArtifactAssembly -> Eff (ArtifactInterpreter e) ()
+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])
+ iid@(IID iidStr) <- IID <$> substStr iidStrTemplate
+ env <- InstanceSources <$> askEnvironment <*> ask
+ withSubstitutedStringBindings
+ [(fromString instanceIdKey, fromString iidStr)]
+ (tell [IG iid env assembly])
-- | Internal data structure. Only exposed for unit testing.
data InstanceSources = InstanceSources
@@ -209,49 +249,61 @@
ArtifactAssembly
deriving (Read, Show, Typeable, Data, Eq)
-toFileInstanceGenerator ::
- Member ExcB9 e => InstanceGenerator InstanceSources -> Eff e (InstanceGenerator [TextFileWriter])
+toFileInstanceGenerator
+ :: Member ExcB9 e
+ => InstanceGenerator InstanceSources
+ -> Eff e (InstanceGenerator [TextFileWriter])
toFileInstanceGenerator (IG iid (InstanceSources env sources) assembly) =
runEnvironmentReader env $ do
- assembly' <- substAssembly assembly
+ assembly' <- substAssembly assembly
sourceGenerators <- join <$> traverse toSourceGen sources
pure (IG iid sourceGenerators assembly')
-substAssembly ::
- forall e. (Member ExcB9 e, Member EnvironmentReader e)
+substAssembly
+ :: forall e
+ . (Member ExcB9 e, Member EnvironmentReader e)
=> ArtifactAssembly
-> Eff e ArtifactAssembly
substAssembly = everywhereM gsubst
- where
- 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
+ where
+ gsubst :: Data a => a -> Eff e a
+ gsubst = mkM substAssembly_ `extM` substImageTarget `extM` substVmScript
+ substAssembly_ (CloudInit ts f) = CloudInit ts <$> substStr f
+ substAssembly_ vm = pure vm
-toSourceGen :: (Member ExcB9 e, Member EnvironmentReader e) => ArtifactSource -> Eff e [TextFileWriter]
+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' <- subst t
- f' <- subst f
- return [MkTextFileWriter env (ExternalFiles [Source conv f']) KeepPermissions t']
+ t' <- substStr t
+ f' <- substStr f
+ return
+ [ MkTextFileWriter env
+ (ExternalFiles [Source conv f'])
+ KeepPermissions
+ t'
+ ]
FromContent t c -> do
- t' <- subst t
+ t' <- substStr t
return [MkTextFileWriter env (StaticContent c) KeepPermissions t']
SetPermissions o g a src' -> do
sgs <- join <$> mapM toSourceGen src'
traverse (setFilePermissionAction o g a) sgs
FromDirectory fromDir src' -> do
- sgs <- join <$> mapM toSourceGen src'
- fromDir' <- subst fromDir
+ sgs <- join <$> mapM toSourceGen src'
+ fromDir' <- substStr fromDir
return (prefixExternalSourcesPaths fromDir' <$> sgs)
IntoDirectory toDir src' -> do
- sgs <- join <$> mapM toSourceGen src'
- toDir' <- subst toDir
+ sgs <- join <$> mapM toSourceGen src'
+ toDir' <- substStr toDir
return (prefixOutputFilePaths toDir' <$> sgs)
-createAssembledArtifacts :: IsB9 e => [InstanceGenerator [TextFileWriter]] -> Eff e [AssembledArtifact]
+createAssembledArtifacts
+ :: IsB9 e => [InstanceGenerator [TextFileWriter]] -> Eff e [AssembledArtifact]
createAssembledArtifacts igs = do
buildDir <- getBuildDir
let outDir = buildDir "artifact-instances"
@@ -259,7 +311,11 @@
generated <- generateSources outDir `mapM` igs
runInstanceGenerator `mapM` generated
-generateSources :: IsB9 e => FilePath -> InstanceGenerator [TextFileWriter] -> Eff e (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)
@@ -269,7 +325,8 @@
return (IG uiid instanceDir assembly)
-- | Run an
-runInstanceGenerator :: IsB9 e => InstanceGenerator FilePath -> Eff e AssembledArtifact
+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)
@@ -283,19 +340,20 @@
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)
+ result <- case sgSource of
+ ExternalFiles froms -> do
+ sources <- mapM readTemplateFile froms
+ return (mconcat sources)
+ StaticContent c -> toContentGenerator c
+ traceL (printf "rendered: \n%s\n" result)
+ liftIO (writeTextFile toAbs result)
runFilePermissionAction toAbs p
-runFilePermissionAction :: IsB9 e => FilePath -> FilePermissionAction -> Eff e ()
+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)
+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
-- boiling down 'ArtifactSource's to a flat list of uniform 'TextFileWriter's.
@@ -320,77 +378,106 @@
| KeepPermissions
deriving (Read, Show, Typeable, Data, Eq)
-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
+ :: 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))
+ | 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))
prefixExternalSourcesPaths :: FilePath -> TextFileWriter -> TextFileWriter
-prefixExternalSourcesPaths fromDir (MkTextFileWriter e (ExternalFiles fs) p d) =
- MkTextFileWriter e (ExternalFiles (prefixExternalSourcePaths <$> fs)) p d
- where
- prefixExternalSourcePaths (Source t f) = Source t (fromDir f)
+prefixExternalSourcesPaths fromDir (MkTextFileWriter e (ExternalFiles fs) p d)
+ = MkTextFileWriter e (ExternalFiles (prefixExternalSourcePaths <$> fs)) p d
+ where prefixExternalSourcePaths (Source t f) = Source t (fromDir f)
prefixExternalSourcesPaths _fromDir sg = sg
prefixOutputFilePaths :: FilePath -> TextFileWriter -> TextFileWriter
-prefixOutputFilePaths toDir (MkTextFileWriter e fs p d) = MkTextFileWriter e fs p (toDir d)
+prefixOutputFilePaths toDir (MkTextFileWriter e fs p d) =
+ MkTextFileWriter e fs p (toDir d)
-- | Create the 'ArtifactTarget' from an 'ArtifactAssembly' in the directory @instanceDir@
--
-- @since 0.5.65
-runArtifactAssembly :: IsB9 e => InstanceId -> FilePath -> ArtifactAssembly -> Eff e [ArtifactTarget]
+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
+ let err_msg = printf "Error creating 'VmImages' for instance '%s'" iidStr
(IID iidStr) = iid
unless success (errorL err_msg >> error err_msg)
return [VmImagesTarget]
-runArtifactAssembly _ instanceDir (CloudInit types outPath) = mapM create_ types
- where
- create_ CI_DIR = do
- let ciDir = outPath
- ensureDir (ciDir ++ "/")
- dbgL (printf "creating directory '%s'" ciDir)
- files <- getDirectoryFiles instanceDir
- traceL (printf "copying files: %s" (show files))
- liftIO
- (mapM_
- (\(f, t) -> do
- ensureDir t
- copyFile f t)
- (((instanceDir ) &&& (ciDir )) <$> files))
- infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))
- return (CloudInitTarget CI_DIR ciDir)
- create_ CI_ISO = do
- buildDir <- getBuildDir
- let isoFile = outPath <.> "iso"
- tmpFile = buildDir takeFileName isoFile
- ensureDir tmpFile
- dbgL (printf "creating cloud init iso temp image '%s', destination file: '%s" tmpFile isoFile)
- cmd (printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1" tmpFile instanceDir)
- dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)
- ensureDir isoFile
- liftIO (copyFile tmpFile isoFile)
- infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))
- return (CloudInitTarget CI_ISO isoFile)
- create_ CI_VFAT = do
- buildDir <- getBuildDir
- let vfatFile = outPath <.> "vfat"
- tmpFile = buildDir takeFileName vfatFile
- ensureDir tmpFile
- files <- map (instanceDir ) <$> getDirectoryFiles instanceDir
- dbgL (printf "creating cloud init vfat image '%s'" tmpFile)
- traceL (printf "adding '%s'" (show files))
- cmd (printf "truncate --size 2M '%s'" tmpFile)
- cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)
- cmd (unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files)) ++ " ::")
- dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)
- ensureDir vfatFile
- liftIO (copyFile tmpFile vfatFile)
- infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))
- return (CloudInitTarget CI_ISO vfatFile)
+runArtifactAssembly _ instanceDir (CloudInit types outPath) = mapM create_
+ types
+ where
+ create_ CI_DIR = do
+ let ciDir = outPath
+ ensureDir (ciDir ++ "/")
+ dbgL (printf "creating directory '%s'" ciDir)
+ files <- getDirectoryFiles instanceDir
+ traceL (printf "copying files: %s" (show files))
+ liftIO
+ (mapM_
+ (\(f, t) -> do
+ ensureDir t
+ copyFile f t
+ )
+ (((instanceDir ) &&& (ciDir )) <$> files)
+ )
+ infoL (printf "CREATED CI_DIR: '%s'" (takeFileName ciDir))
+ return (CloudInitTarget CI_DIR ciDir)
+ create_ CI_ISO = do
+ buildDir <- getBuildDir
+ let isoFile = outPath <.> "iso"
+ tmpFile = buildDir takeFileName isoFile
+ ensureDir tmpFile
+ dbgL
+ (printf "creating cloud init iso temp image '%s', destination file: '%s"
+ tmpFile
+ isoFile
+ )
+ cmd
+ (printf "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"
+ tmpFile
+ instanceDir
+ )
+ dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)
+ ensureDir isoFile
+ liftIO (copyFile tmpFile isoFile)
+ infoL (printf "CREATED CI_ISO IMAGE: '%s'" (takeFileName isoFile))
+ return (CloudInitTarget CI_ISO isoFile)
+ create_ CI_VFAT = do
+ buildDir <- getBuildDir
+ let vfatFile = outPath <.> "vfat"
+ tmpFile = buildDir takeFileName vfatFile
+ ensureDir tmpFile
+ files <- map (instanceDir ) <$> getDirectoryFiles instanceDir
+ dbgL (printf "creating cloud init vfat image '%s'" tmpFile)
+ traceL (printf "adding '%s'" (show files))
+ cmd (printf "truncate --size 2M '%s'" tmpFile)
+ cmd (printf "mkfs.vfat -n cidata '%s' 2>&1" tmpFile)
+ cmd
+ ( unwords (printf "mcopy -oi '%s' " tmpFile : (printf "'%s'" <$> files))
+ ++ " ::"
+ )
+ dbgL (printf "moving vfat image '%s' to '%s'" tmpFile vfatFile)
+ ensureDir vfatFile
+ liftIO (copyFile tmpFile vfatFile)
+ infoL (printf "CREATED CI_VFAT IMAGE: '%s'" (takeFileName vfatFile))
+ return (CloudInitTarget CI_ISO vfatFile)
diff --git a/src/lib/B9/Artifact/Readable/Source.hs b/src/lib/B9/Artifact/Readable/Source.hs
--- a/src/lib/B9/Artifact/Readable/Source.hs
+++ b/src/lib/B9/Artifact/Readable/Source.hs
@@ -4,12 +4,13 @@
module B9.Artifact.Readable.Source
( ArtifactSource(..)
, getArtifactSourceFiles
- ) where
+ )
+where
import Control.Parallel.Strategies
import Data.Data
-import GHC.Generics (Generic)
-import System.FilePath (())
+import GHC.Generics ( Generic )
+import System.FilePath ( () )
import B9.Artifact.Content.Readable
import B9.Artifact.Content.StringTemplate
@@ -49,17 +50,22 @@
-- | Return all source files generated by an 'ArtifactSource'.
getArtifactSourceFiles :: ArtifactSource -> [FilePath]
getArtifactSourceFiles (FromContent f _) = [f]
-getArtifactSourceFiles (FromFile f _) = [f]
-getArtifactSourceFiles (IntoDirectory pd as) = (pd ) <$> (as >>= getArtifactSourceFiles)
+getArtifactSourceFiles (FromFile f _) = [f]
+getArtifactSourceFiles (IntoDirectory pd as) =
+ (pd ) <$> (as >>= getArtifactSourceFiles)
getArtifactSourceFiles (FromDirectory _ as) = as >>= getArtifactSourceFiles
-getArtifactSourceFiles (SetPermissions _ _ _ as) = as >>= getArtifactSourceFiles
+getArtifactSourceFiles (SetPermissions _ _ _ as) =
+ as >>= getArtifactSourceFiles
instance Arbitrary ArtifactSource where
- arbitrary =
- oneof
- [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary
- , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary
- , SetPermissions <$> choose (0, 7) <*> choose (0, 7) <*> choose (0, 7) <*> smaller arbitrary
- , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary
- , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary
- ]
+ arbitrary = oneof
+ [ FromFile <$> smaller arbitraryFilePath <*> smaller arbitrary
+ , FromContent <$> smaller arbitraryFilePath <*> smaller arbitrary
+ , SetPermissions
+ <$> choose (0, 7)
+ <*> choose (0, 7)
+ <*> choose (0, 7)
+ <*> smaller arbitrary
+ , FromDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary
+ , IntoDirectory <$> smaller arbitraryFilePath <*> smaller arbitrary
+ ]
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
@@ -55,41 +55,54 @@
, ExecEnvType(..)
, Environment
, module X
- ) where
-
-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 Data.ConfigFile.B9Extras
- ( CPDocument
- , CPError
- , CPGet
- , CPOptionSpec
- , CPReadException(..)
- , addSectionCP
- , emptyCP
- , mergeCP
- , readCP
- , readCPDocument
- , setShowCP
- , toStringCP
)
-import Data.Function (on)
-import Data.Maybe (fromMaybe)
-import Data.Monoid
-import Data.Semigroup as Semigroup hiding (Last(..))
-import System.Directory
-import System.IO.B9Extras (SystemPath(..), ensureDir, resolve)
-import Text.Printf (printf)
+where
-import B9.Environment
+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 Data.ConfigFile.B9Extras ( CPDocument
+ , CPError
+ , CPGet
+ , CPOptionSpec
+ , CPReadException(..)
+ , addSectionCP
+ , emptyCP
+ , mergeCP
+ , readCP
+ , readCPDocument
+ , setShowCP
+ , toStringCP
+ )
+import Data.Function ( on )
+import Data.Maybe ( fromMaybe )
+import Data.Monoid
+import Data.Semigroup as Semigroup
+ hiding ( Last(..) )
+import System.Directory
+import System.IO.B9Extras ( SystemPath(..)
+ , ensureDir
+ , resolve
+ )
+import Text.Printf ( printf )
+import B9.Environment
+
data ExecEnvType =
LibVirtLXC
deriving (Eq, Show, Ord, Read)
@@ -118,25 +131,37 @@
} deriving (Show, Eq)
instance Semigroup B9Config where
- c <> c' =
- B9Config
- { _verbosity = getLast $ on mappend (Last . _verbosity) c c'
- , _logFile = getLast $ on mappend (Last . _logFile) c c'
- , _projectRoot = getLast $ on mappend (Last . _projectRoot) c c'
- , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'
- , _execEnvType = LibVirtLXC
- , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')
- , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'
- , _repository = getLast ((mappend `on` (Last . _repository)) c c')
- , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')
- , _maxLocalSharedImageRevisions = getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')
- , _libVirtLXCConfigs = getLast ((mappend `on` (Last . _libVirtLXCConfigs)) c c')
- , _remoteRepos = (mappend `on` _remoteRepos) c c'
- }
+ c <> c' = B9Config
+ { _verbosity = getLast $ on mappend (Last . _verbosity) c c'
+ , _logFile = getLast $ on mappend (Last . _logFile) c c'
+ , _projectRoot = getLast $ on mappend (Last . _projectRoot) c c'
+ , _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'
+ , _execEnvType = LibVirtLXC
+ , _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')
+ , _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'
+ , _repository = getLast ((mappend `on` (Last . _repository)) c c')
+ , _interactive = getAny ((mappend `on` (Any . _interactive)) c c')
+ , _maxLocalSharedImageRevisions =
+ getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')
+ , _libVirtLXCConfigs = getLast
+ ((mappend `on` (Last . _libVirtLXCConfigs)) c c')
+ , _remoteRepos = (mappend `on` _remoteRepos) c c'
+ }
instance Monoid B9Config where
mappend = (<>)
- mempty = B9Config Nothing Nothing Nothing False LibVirtLXC True Nothing Nothing False Nothing Nothing []
+ mempty = B9Config Nothing
+ Nothing
+ Nothing
+ False
+ LibVirtLXC
+ True
+ Nothing
+ Nothing
+ False
+ Nothing
+ Nothing
+ []
-- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'.
--
@@ -160,7 +185,8 @@
-- | 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
+ :: Member B9ConfigReader e => (B9Config -> B9Config) -> Eff e a -> Eff e a
localB9Config = local
-- | An alias for 'getB9Config'.
@@ -225,7 +251,8 @@
overrideB9ConfigPath p = customB9ConfigPath ?~ p
-- | Modify the runtime configuration.
-overrideB9Config :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride
+overrideB9Config
+ :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride
overrideB9Config = over customB9Config
-- | Define the current working directory to be used when building.
@@ -247,7 +274,8 @@
-- 'B9ConfigReader' and 'IO'.
--
-- @since 0.5.65
-type B9ConfigAction a = Eff '[ B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a
+type B9ConfigAction a
+ = Eff '[B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a
-- | Accumulate 'B9Config' changes that go back to the config file. See
-- 'B9ConfigAction' and 'modifyPermanentConfig'.
@@ -278,25 +306,44 @@
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))
+ Left e -> fail
+ (printf "Internal configuration load error, please report this: %s\n"
+ (show e)
+ )
Right permanentConfigIn -> do
let runtimeCfg =
let rc = permanentConfigIn <> (cfg ^. customB9Config)
- in case cfg ^. customLibVirtNetwork of
- Just overridenNetwork -> rc & libVirtLXCConfigs . _Just . networkId .~ overridenNetwork
+ in case cfg ^. customLibVirtNetwork of
+ Just overridenNetwork ->
+ rc
+ & libVirtLXCConfigs
+ . _Just
+ . networkId
+ .~ overridenNetwork
Nothing -> rc
- (res, permanentB9ConfigUpdates) <-
- runLift (runEnvironmentReader (cfg ^. customEnvironment) (runReader runtimeCfg (runMonoidWriter act)))
+ (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 permanentB9ConfigUpdates
- cpExt <-
- maybe
- (return Nothing)
- (either (fail . printf "Internal configuration update error! Please report this: %s\n" . show) (return . Just))
- cpExtErr
+ if appEndo permanentB9ConfigUpdates permanentConfigIn
+ == permanentConfigIn
+ then
+ Nothing
+ else
+ Just permanentB9ConfigUpdates
+ cpExt <- maybe
+ (return Nothing)
+ (either
+ ( fail
+ . printf
+ "Internal configuration update error! Please report this: %s\n"
+ . show
+ )
+ (return . Just)
+ )
+ cpExtErr
mapM_ (writeB9CPDocument (cfg ^. customB9ConfigPath)) cpExt
return res
@@ -318,10 +365,11 @@
exists <- doesFileExist cfgFile
if exists
then readCPDocument (Path cfgFile)
- else let res = b9ConfigToCPDocument defaultB9Config
- in case res of
- Left e -> throwIO (CPReadException cfgFile e)
- Right cp -> writeFile cfgFile (toStringCP cp) >> return cp
+ else
+ let res = b9ConfigToCPDocument defaultB9Config
+ in case res of
+ Left e -> throwIO (CPReadException cfgFile e)
+ Right cp -> writeFile cfgFile (toStringCP cp) >> return cp
-- | Write the configuration in the 'CPDocument' to either the user supplied
-- configuration file path or to 'defaultB9ConfigFile'.
@@ -333,21 +381,19 @@
liftIO (writeFile cfgFile (toStringCP cp))
defaultB9Config :: B9Config
-defaultB9Config =
- B9Config
- { _verbosity = Just LogInfo
- , _logFile = Nothing
- , _projectRoot = Nothing
- , _keepTempDirs = False
- , _execEnvType = LibVirtLXC
- , _uniqueBuildDirs = True
- , _repository = Nothing
- , _repositoryCache = Just defaultRepositoryCache
- , _interactive = False
- , _maxLocalSharedImageRevisions = Just 2
- , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig
- , _remoteRepos = []
- }
+defaultB9Config = B9Config { _verbosity = Just LogInfo
+ , _logFile = Nothing
+ , _projectRoot = Nothing
+ , _keepTempDirs = False
+ , _execEnvType = LibVirtLXC
+ , _uniqueBuildDirs = True
+ , _repository = Nothing
+ , _repositoryCache = Just defaultRepositoryCache
+ , _interactive = False
+ , _maxLocalSharedImageRevisions = Just 2
+ , _libVirtLXCConfigs = Just defaultLibVirtLXCConfig
+ , _remoteRepos = []
+ }
defaultRepositoryCache :: SystemPath
defaultRepositoryCache = InB9UserDir "repo-cache"
@@ -402,9 +448,15 @@
cp5 <- setShowCP cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)
cp6 <- setShowCP cp5 cfgFileSection execEnvTypeK (_execEnvType c)
cp7 <- setShowCP cp6 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)
- cp8 <- setShowCP cp7 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c)
+ cp8 <- setShowCP cp7
+ cfgFileSection
+ maxLocalSharedImageRevisionsK
+ (_maxLocalSharedImageRevisions c)
cp9 <- setShowCP cp8 cfgFileSection repositoryCacheK (_repositoryCache c)
- cpA <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cp9
+ cpA <- foldr (>=>)
+ return
+ (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c)
+ cp9
cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpA
setShowCP cpFinal cfgFileSection repositoryK (_repository c)
@@ -413,13 +465,20 @@
parseB9Config :: CPDocument -> Either CPError B9Config
parseB9Config cp =
- let getr :: (CPGet a) => CPOptionSpec -> Either CPError a
- getr = readCP cp cfgFileSection
- 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
+ let
+ getr :: (CPGet a) => CPOptionSpec -> Either CPError a
+ getr = readCP cp cfgFileSection
+ 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/Repository.hs b/src/lib/B9/B9Config/Repository.hs
--- a/src/lib/B9/B9Config/Repository.hs
+++ b/src/lib/B9/B9Config/Repository.hs
@@ -1,16 +1,18 @@
-module B9.B9Config.Repository ( RemoteRepo(..)
- , remoteRepoRepoId
- , RepoCache(..)
- , SshPrivKey(..)
- , SshRemoteHost(..)
- , SshRemoteUser(..)
- , remoteRepoToCPDocument
- , parseRemoteRepos
- ) where
+module B9.B9Config.Repository
+ ( RemoteRepo(..)
+ , remoteRepoRepoId
+ , RepoCache(..)
+ , SshPrivKey(..)
+ , SshRemoteHost(..)
+ , SshRemoteUser(..)
+ , remoteRepoToCPDocument
+ , parseRemoteRepos
+ )
+where
-import Data.Data
-import Data.List (isSuffixOf)
-import Data.ConfigFile.B9Extras
+import Data.Data
+import Data.List ( isSuffixOf )
+import Data.ConfigFile.B9Extras
newtype RepoCache = RepoCache FilePath
deriving (Read, Show, Typeable, Data)
diff --git a/src/lib/B9/B9Exec.hs b/src/lib/B9/B9Exec.hs
--- a/src/lib/B9/B9Exec.hs
+++ b/src/lib/B9/B9Exec.hs
@@ -3,22 +3,28 @@
-- @since 0.5.65
module B9.B9Exec
( cmd
- ) where
+ )
+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
+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 as Strict
+import Data.Conduit ( (.|)
+ , runConduit
+ )
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Process
+import Data.Functor ( )
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Encoding.Error as Text
+import System.Exit
+import Text.Printf
-- | Execute the given shell command.
--
@@ -35,45 +41,41 @@
cmd :: CommandIO e => String -> Eff e ()
cmd str = do
inheritStdIn <- isInteractive
- if inheritStdIn
- then interactiveCmd str
- else nonInteractiveCmd str
+ if inheritStdIn then interactiveCmd str else nonInteractiveCmd str
-interactiveCmd ::
- forall e. CommandIO e
- => String
- -> Eff e ()
+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 ()
+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
+ :: (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)
+ traceLIO <- embed_
+ (traceL . Text.unpack . Text.decodeUtf8With Text.lenientDecode)
+ errorLIO <- embed_
+ (errorL . Text.unpack . Text.decodeUtf8With Text.lenientDecode)
let errorLC = CL.mapM_ (liftIO . errorLIO)
- let traceLC =
- if toStdOut
- then CL.mapM_ Strict.putStr
- else CL.mapM_ (liftIO . traceLIO)
+ 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)
+ 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
+ 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
--- a/src/lib/B9/B9Logging.hs
+++ b/src/lib/B9/B9Logging.hs
@@ -12,20 +12,24 @@
, infoL
, errorL
, errorExitL
- ) where
+ )
+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
+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.
--
@@ -45,20 +49,28 @@
-- 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
+ :: (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
+ 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)
+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
@@ -77,7 +89,7 @@
b9Log :: CommandIO e => LogLevel -> String -> Eff e ()
b9Log level msg = do
- lv <- getLogVerbosity
+ lv <- getLogVerbosity
lfh <- logFileHandle <$> ask
liftIO $ logImpl lv lfh level msg
@@ -96,10 +108,9 @@
return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg
printLevel :: LogLevel -> String
-printLevel l =
- case l of
- LogNothing -> "NOTHING"
- LogError -> " ERROR "
- LogInfo -> " INFO "
- LogDebug -> " DEBUG "
- LogTrace -> " TRACE "
+printLevel l = case l of
+ LogNothing -> "NOTHING"
+ LogError -> " ERROR "
+ LogInfo -> " INFO "
+ LogDebug -> " DEBUG "
+ LogTrace -> " TRACE "
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
@@ -3,16 +3,17 @@
, B9
, B9Eff
, IsB9
- ) where
+ )
+where
-import B9.B9Config
-import B9.B9Error
-import B9.B9Logging
-import B9.BuildInfo
-import B9.Environment
-import B9.Repository
-import Control.Eff
-import Data.Functor ()
+import B9.B9Config
+import B9.B9Error
+import B9.B9Logging
+import B9.BuildInfo
+import B9.Environment
+import B9.Repository
+import Control.Eff
+import Data.Functor ( )
-- | Definition of the B9 monad. See 'B9Eff'.
--
@@ -29,7 +30,8 @@
--
-- @since 0.5.65
type B9Eff
- = '[ SelectedRemoteRepoReader, RepoCacheReader, BuildInfoReader, LoggerReader, B9ConfigReader, EnvironmentReader, ExcB9, Lift IO]
+ = '[SelectedRemoteRepoReader, RepoCacheReader, BuildInfoReader, LoggerReader, B9ConfigReader, EnvironmentReader, ExcB9, Lift
+ IO]
-- | A constraint that contains all effects of 'B9Eff'
--
@@ -45,8 +47,13 @@
cfg <- getB9Config
env <- askEnvironment
lift
- (runLift .
- errorOnException .
- runEnvironmentReader env .
- runB9ConfigReader cfg . withLogger . withBuildInfo . withRemoteRepos . withSelectedRemoteRepo $
- action)
+ ( 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
--- a/src/lib/B9/BuildInfo.hs
+++ b/src/lib/B9/BuildInfo.hs
@@ -11,26 +11,29 @@
, getExecEnvType
, withBuildInfo
, BuildInfoReader
- ) where
+ )
+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
+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.
--
@@ -55,8 +58,8 @@
-- returns - even if the action throws a runtime exception.
--
-- @since 0.5.65
-withBuildInfo ::
- ( Lifted IO e
+withBuildInfo
+ :: ( Lifted IO e
, MonadBaseControl IO (Eff e)
, Member B9ConfigReader e
, Member ExcB9 e
@@ -65,57 +68,56 @@
)
=> 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
+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
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
@@ -80,15 +80,15 @@
`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
+ substMountPoint (MountPoint x) = MountPoint <$> substStr x
+ substImage (Image fp t fs) = Image <$> substStr fp <*> pure t <*> pure fs
+ substImageSource (From n s) = From <$> substStr n <*> pure s
substImageSource (EmptyImage l f t s) =
- EmptyImage <$> subst l <*> pure f <*> pure t <*> pure s
+ EmptyImage <$> substStr l <*> pure f <*> pure t <*> pure s
substImageSource s = pure s
- substDiskTarget (Share n t s) = Share <$> subst n <*> pure t <*> pure s
+ substDiskTarget (Share n t s) = Share <$> substStr n <*> pure t <*> pure s
substDiskTarget (LiveInstallerImage name outDir resize) =
- LiveInstallerImage <$> subst name <*> subst outDir <*> pure resize
+ LiveInstallerImage <$> substStr name <*> substStr outDir <*> pure resize
substDiskTarget s = pure s
-- | Resolve an ImageSource to an 'Image'. The ImageSource might
@@ -174,7 +174,8 @@
materializeImageSource (SourceImage sharedImg NoPT resize) dest
)
-createImageFromImage :: IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e ()
+createImageFromImage
+ :: IsB9 e => Image -> Partition -> ImageResize -> Image -> Eff e ()
createImageFromImage src part size out = do
importImage src out
extractPartition part out
@@ -237,7 +238,13 @@
Transient -> return ()
createEmptyImage
- :: IsB9 e => String -> FileSystem -> ImageType -> ImageSize -> Image -> Eff e ()
+ :: IsB9 e
+ => String
+ -> FileSystem
+ -> ImageType
+ -> ImageSize
+ -> Image
+ -> Eff e ()
createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType')
| fsType /= fsType' = error
(printf
@@ -389,7 +396,8 @@
-- | Return a 'SharedImage' with the current build data and build id from the
-- name and disk image.
-getSharedImageFromImageInfo :: IsB9 e => SharedImageName -> Image -> Eff e SharedImage
+getSharedImageFromImageInfo
+ :: IsB9 e => SharedImageName -> Image -> Eff e SharedImage
getSharedImageFromImageInfo name (Image _ imgType imgFS) = do
buildId <- getBuildId
date <- getBuildDate
@@ -404,7 +412,8 @@
-- | 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 :: IsB9 e => Image -> SharedImageName -> Eff e 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
@@ -430,7 +439,7 @@
-- | Upload a shared image from the cache to a selected remote repository
pushToSelectedRepo :: IsB9 e => SharedImage -> Eff e ()
pushToSelectedRepo i = do
- c <- getSharedImagesCacheDir
+ c <- getSharedImagesCacheDir
MkSelectedRemoteRepo r <- getSelectedRemoteRepo
when (isJust r) $ do
let (Image imgFile' _imgType _imgFS) = sharedImageImage i
@@ -499,7 +508,8 @@
return image
-- | Return the latest version of a shared image named 'name' from the local cache.
-getLatestSharedImageByNameFromCache :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImage)
+getLatestSharedImageByNameFromCache
+ :: IsB9 e => SharedImageName -> Eff e (Maybe SharedImage)
getLatestSharedImageByNameFromCache name@(SharedImageName dbgName) = do
imgs <- lookupSharedImages (== Cache) ((== name) . sharedImageName)
case reverse imgs of
@@ -533,7 +543,8 @@
-- | Find shared images and the associated repos from two predicates. The result
-- is the concatenated result of the sorted shared images satisfying 'imgPred'.
lookupSharedImages
- ::IsB9 e => (Repository -> Bool)
+ :: IsB9 e
+ => (Repository -> Bool)
-> (SharedImage -> Bool)
-> Eff e [(Repository, SharedImage)]
lookupSharedImages repoPred imgPred = do
@@ -545,9 +556,9 @@
return (mconcat (pure <$> sorted))
-- | Return either all remote repos or just the single selected repo.
-getSelectedRepos ::IsB9 e => Eff e [RemoteRepo]
+getSelectedRepos :: IsB9 e => Eff e [RemoteRepo]
getSelectedRepos = do
- allRepos <- getRemoteRepos
+ allRepos <- getRemoteRepos
MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo
let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo
return repos
diff --git a/src/lib/B9/DiskImages.hs b/src/lib/B9/DiskImages.hs
--- a/src/lib/B9/DiskImages.hs
+++ b/src/lib/B9/DiskImages.hs
@@ -3,16 +3,16 @@
module B9.DiskImages where
import B9.QCUtil
-import GHC.Generics (Generic)
+import GHC.Generics ( Generic )
import Control.Parallel.Strategies
import Data.Binary
import Data.Data
import Data.Hashable
import Data.Maybe
-import Data.Semigroup as Sem
+import Data.Semigroup as Sem
import System.FilePath
import Test.QuickCheck
-import qualified Text.PrettyPrint.Boxes as Boxes
+import qualified Text.PrettyPrint.Boxes as Boxes
import Text.Printf
-- * Data types for disk image description, e.g. 'ImageTarget',
@@ -204,8 +204,8 @@
-- | Shared images are orderd by name, build date and build id
instance Ord SharedImage where
- compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =
- compare n n' Sem.<> compare d d' Sem.<> compare b b'
+ compare (SharedImage n d b _ _) (SharedImage n' d' b' _ _) =
+ compare n n' Sem.<> compare d d' Sem.<> compare b b'
-- * Constroctor and accessors for 'Image' 'ImageTarget' 'ImageSource'
-- 'ImageDestination' and 'SharedImage'
@@ -222,25 +222,24 @@
-- are treated like they have no ouput files because the output files are manged
-- by B9.
getImageDestinationOutputFiles :: ImageTarget -> [FilePath]
-getImageDestinationOutputFiles (ImageTarget d _ _) =
- case d of
- LiveInstallerImage liName liPath _ ->
- let path = liPath "machines" liName "disks" "raw"
- in [path "0.raw", path "0.size", path "VERSION"]
- LocalFile (Image lfPath _ _) _ -> [lfPath]
- _ -> []
+getImageDestinationOutputFiles (ImageTarget d _ _) = case d of
+ LiveInstallerImage liName liPath _ ->
+ let path = liPath "machines" liName "disks" "raw"
+ in [path "0.raw", path "0.size", path "VERSION"]
+ LocalFile (Image lfPath _ _) _ -> [lfPath]
+ _ -> []
-- | Return the name of a shared image, if the 'ImageDestination' is a 'Share'
-- destination
imageDestinationSharedImageName :: ImageDestination -> Maybe SharedImageName
imageDestinationSharedImageName (Share n _ _) = Just (SharedImageName n)
-imageDestinationSharedImageName _ = Nothing
+imageDestinationSharedImageName _ = Nothing
-- | Return the name of a shared source image, if the 'ImageSource' is a 'From'
-- source
imageSourceSharedImageName :: ImageSource -> Maybe SharedImageName
imageSourceSharedImageName (From n _) = Just (SharedImageName n)
-imageSourceSharedImageName _ = Nothing
+imageSourceSharedImageName _ = Nothing
-- | Get the 'ImageDestination' of an 'ImageTarget'
itImageDestination :: ImageTarget -> ImageDestination
@@ -258,39 +257,38 @@
-- | Return true if a 'Partition' parameter is actually refering to a partition,
-- false if it is 'NoPT'
isPartitioned :: Partition -> Bool
-isPartitioned p
- | p == NoPT = False
- | otherwise = True
+isPartitioned p | p == NoPT = False
+ | otherwise = True
-- | Return the 'Partition' index or throw a runtime error if aplied to 'NoPT'
getPartition :: Partition -> Int
getPartition (Partition p) = p
-getPartition NoPT = error "No partitions!"
+getPartition NoPT = error "No partitions!"
-- | Return the file name extension of an image file with a specific image
-- format.
imageFileExtension :: ImageType -> String
-imageFileExtension Raw = "raw"
+imageFileExtension Raw = "raw"
imageFileExtension QCow2 = "qcow2"
-imageFileExtension Vmdk = "vmdk"
+imageFileExtension Vmdk = "vmdk"
-- | Change the image file format and also rename the image file name to
-- have the appropriate file name extension. See 'imageFileExtension' and
-- 'replaceExtension'
changeImageFormat :: ImageType -> Image -> Image
changeImageFormat fmt' (Image img _ fs) = Image img' fmt' fs
- where img' = replaceExtension img (imageFileExtension fmt')
+ where img' = replaceExtension img (imageFileExtension fmt')
changeImageDirectory :: FilePath -> Image -> Image
changeImageDirectory dir (Image img fmt fs) = Image img' fmt fs
- where img' = dir takeFileName img
+ where img' = dir takeFileName img
-- * Constructors and accessors for 'ImageSource's
getImageSourceImageType :: ImageSource -> Maybe ImageType
getImageSourceImageType (EmptyImage _ _ t _) = Just t
-getImageSourceImageType (CopyOnWrite i) = Just $ imageImageType i
-getImageSourceImageType (SourceImage i _ _) = Just $ imageImageType i
-getImageSourceImageType (From _ _) = Nothing
+getImageSourceImageType (CopyOnWrite i ) = Just $ imageImageType i
+getImageSourceImageType (SourceImage i _ _ ) = Just $ imageImageType i
+getImageSourceImageType (From _ _ ) = Nothing
-- * Constructors and accessors for 'SharedImage's
@@ -316,30 +314,30 @@
where
nameC = col "Name" ((\(SharedImageName n) -> n) . sharedImageName)
dateC = col "Date" ((\(SharedImageDate n) -> n) . sharedImageDate)
- idC = col "ID" ((\(SharedImageBuildId n) -> n) . sharedImageBuildId)
- col title accessor = Boxes.text title Boxes.// Boxes.vcat Boxes.left cells
- where
- cells = Boxes.text . accessor <$> imgs
+ idC = col "ID"
+ ((\(SharedImageBuildId n) -> n) . sharedImageBuildId)
+ col title accessor =
+ Boxes.text title Boxes.// Boxes.vcat Boxes.left cells
+ where cells = Boxes.text . accessor <$> imgs
-- | Return the disk image of an sharedImage
sharedImageImage :: SharedImage -> Image
-sharedImageImage (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) sharedImageType sharedImageFileSystem) =
- Image
- (n ++ "_" ++ bid <.> imageFileExtension sharedImageType)
- sharedImageType
- sharedImageFileSystem
+sharedImageImage (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) sharedImageType sharedImageFileSystem)
+ = Image (n ++ "_" ++ bid <.> imageFileExtension sharedImageType)
+ sharedImageType
+ sharedImageFileSystem
-- | Calculate the path to the text file holding the serialized 'SharedImage'
-- relative to the directory of shared images in a repository.
sharedImageFileName :: SharedImage -> FilePath
-sharedImageFileName (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) _ _) =
- n ++ "_" ++ bid <.> sharedImageFileExtension
+sharedImageFileName (SharedImage (SharedImageName n) _ (SharedImageBuildId bid) _ _)
+ = n ++ "_" ++ bid <.> sharedImageFileExtension
sharedImagesRootDirectory :: FilePath
sharedImagesRootDirectory = "b9_shared_images"
sharedImageFileExtension :: String
-sharedImageFileExtension = "b9si"
+sharedImageFileExtension = "b9si"
-- | The internal image type to use as best guess when dealing with a 'From'
-- value.
@@ -350,11 +348,10 @@
-- | Use a 'QCow2' image with an 'Ext4' file system
transientCOWImage :: FilePath -> FilePath -> ImageTarget
-transientCOWImage fileName mountPoint =
- ImageTarget
- Transient
- (CopyOnWrite (Image fileName QCow2 Ext4))
- (MountPoint mountPoint)
+transientCOWImage fileName mountPoint = ImageTarget
+ Transient
+ (CopyOnWrite (Image fileName QCow2 Ext4))
+ (MountPoint mountPoint)
-- | Use a shared image
transientSharedImage :: SharedImageName -> FilePath -> ImageTarget
@@ -368,128 +365,119 @@
-- | Share a 'QCow2' image with 'Ext4' fs
shareCOWImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget
-shareCOWImage srcFilename (SharedImageName destName) mountPoint =
- ImageTarget
- (Share destName QCow2 KeepSize)
- (CopyOnWrite (Image srcFilename QCow2 Ext4))
- (MountPoint mountPoint)
+shareCOWImage srcFilename (SharedImageName destName) mountPoint = ImageTarget
+ (Share destName QCow2 KeepSize)
+ (CopyOnWrite (Image srcFilename QCow2 Ext4))
+ (MountPoint mountPoint)
-- | Share an image based on a shared image
-shareSharedImage :: SharedImageName
- -> SharedImageName
- -> FilePath
- -> ImageTarget
-shareSharedImage (SharedImageName srcName) (SharedImageName destName) mountPoint =
- ImageTarget
- (Share destName QCow2 KeepSize)
- (From srcName KeepSize)
- (MountPoint mountPoint)
+shareSharedImage
+ :: SharedImageName -> SharedImageName -> FilePath -> ImageTarget
+shareSharedImage (SharedImageName srcName) (SharedImageName destName) mountPoint
+ = ImageTarget (Share destName QCow2 KeepSize)
+ (From srcName KeepSize)
+ (MountPoint mountPoint)
-- | Share a 'QCow2' image with 'Ext4' fs
shareLocalImage :: FilePath -> SharedImageName -> FilePath -> ImageTarget
-shareLocalImage srcName (SharedImageName destName) mountPoint =
- ImageTarget
- (Share destName QCow2 KeepSize)
- (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
- (MountPoint mountPoint)
+shareLocalImage srcName (SharedImageName destName) mountPoint = ImageTarget
+ (Share destName QCow2 KeepSize)
+ (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
+ (MountPoint mountPoint)
-- | Export a 'QCow2' image with 'Ext4' fs
-cowToliveInstallerImage :: String
- -> FilePath
- -> FilePath
- -> FilePath
- -> ImageTarget
-cowToliveInstallerImage srcName destName outDir mountPoint =
- ImageTarget
- (LiveInstallerImage destName outDir KeepSize)
- (CopyOnWrite (Image srcName QCow2 Ext4))
- (MountPoint mountPoint)
+cowToliveInstallerImage
+ :: String -> FilePath -> FilePath -> FilePath -> ImageTarget
+cowToliveInstallerImage srcName destName outDir mountPoint = ImageTarget
+ (LiveInstallerImage destName outDir KeepSize)
+ (CopyOnWrite (Image srcName QCow2 Ext4))
+ (MountPoint mountPoint)
-- | Export a 'QCow2' image file with 'Ext4' fs as
-- a local file
cowToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget
-cowToLocalImage srcName destName mountPoint =
- ImageTarget
- (LocalFile (Image destName QCow2 Ext4) KeepSize)
- (CopyOnWrite (Image srcName QCow2 Ext4))
- (MountPoint mountPoint)
+cowToLocalImage srcName destName mountPoint = ImageTarget
+ (LocalFile (Image destName QCow2 Ext4) KeepSize)
+ (CopyOnWrite (Image srcName QCow2 Ext4))
+ (MountPoint mountPoint)
-- | Export a 'QCow2' image file with 'Ext4' fs as
-- a local file
localToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget
-localToLocalImage srcName destName mountPoint =
- ImageTarget
- (LocalFile (Image destName QCow2 Ext4) KeepSize)
- (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
- (MountPoint mountPoint)
+localToLocalImage srcName destName mountPoint = ImageTarget
+ (LocalFile (Image destName QCow2 Ext4) KeepSize)
+ (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
+ (MountPoint mountPoint)
-- | Create a local image file from the contents of the first partition
-- of a local 'QCow2' image.
partition1ToLocalImage :: FilePath -> FilePath -> FilePath -> ImageTarget
-partition1ToLocalImage srcName destName mountPoint =
- ImageTarget
- (LocalFile (Image destName QCow2 Ext4) KeepSize)
- (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
- (MountPoint mountPoint)
+partition1ToLocalImage srcName destName mountPoint = ImageTarget
+ (LocalFile (Image destName QCow2 Ext4) KeepSize)
+ (SourceImage (Image srcName QCow2 Ext4) NoPT KeepSize)
+ (MountPoint mountPoint)
-- * 'ImageTarget' Transformations
-- | Split any image target into two image targets, one for creating an intermediate shared image and one
-- from the intermediate shared image to the output image.
-splitToIntermediateSharedImage :: ImageTarget
- -> SharedImageName
- -> (ImageTarget, ImageTarget)
-splitToIntermediateSharedImage (ImageTarget dst src mnt) (SharedImageName intermediateName) =
- (imgTargetShared, imgTargetExport)
+splitToIntermediateSharedImage
+ :: ImageTarget -> SharedImageName -> (ImageTarget, ImageTarget)
+splitToIntermediateSharedImage (ImageTarget dst src mnt) (SharedImageName intermediateName)
+ = (imgTargetShared, imgTargetExport)
where
imgTargetShared = ImageTarget intermediateTo src mnt
imgTargetExport = ImageTarget dst intermediateFrom mnt
- intermediateTo =
- Share
- intermediateName
- (fromMaybe
- sharedImageDefaultImageType
- (getImageSourceImageType src))
- KeepSize
+ intermediateTo = Share
+ intermediateName
+ (fromMaybe sharedImageDefaultImageType (getImageSourceImageType src))
+ KeepSize
intermediateFrom = From intermediateName KeepSize
-- * 'Arbitrary' instances for quickcheck
instance Arbitrary ImageTarget where
arbitrary =
- ImageTarget <$> smaller arbitrary <*> smaller arbitrary <*>
- smaller arbitrary
+ ImageTarget
+ <$> smaller arbitrary
+ <*> smaller arbitrary
+ <*> smaller arbitrary
instance Arbitrary ImageSource where
- arbitrary =
- oneof
- [ EmptyImage "img-label" <$> smaller arbitrary <*>
- smaller arbitrary <*>
- smaller arbitrary
- , CopyOnWrite <$> smaller arbitrary
- , SourceImage <$> smaller arbitrary <*> smaller arbitrary <*>
- smaller arbitrary
- , From <$> arbitrarySharedImageName <*> smaller arbitrary]
+ arbitrary = oneof
+ [ EmptyImage "img-label"
+ <$> smaller arbitrary
+ <*> smaller arbitrary
+ <*> smaller arbitrary
+ , CopyOnWrite <$> smaller arbitrary
+ , SourceImage
+ <$> smaller arbitrary
+ <*> smaller arbitrary
+ <*> smaller arbitrary
+ , From <$> arbitrarySharedImageName <*> smaller arbitrary
+ ]
instance Arbitrary ImageDestination where
- arbitrary =
- oneof
- [ Share <$> arbitrarySharedImageName <*> smaller arbitrary <*>
- smaller arbitrary
- , LiveInstallerImage "live-installer" "output-path" <$>
- smaller arbitrary
- , pure Transient]
+ arbitrary = oneof
+ [ Share
+ <$> arbitrarySharedImageName
+ <*> smaller arbitrary
+ <*> smaller arbitrary
+ , LiveInstallerImage "live-installer" "output-path"
+ <$> smaller arbitrary
+ , pure Transient
+ ]
instance Arbitrary MountPoint where
arbitrary = elements [MountPoint "/mnt", NotMounted]
instance Arbitrary ImageResize where
- arbitrary =
- oneof
- [ ResizeImage <$> smaller arbitrary
- , Resize <$> smaller arbitrary
- , pure ShrinkToMinimum
- , pure KeepSize]
+ arbitrary = oneof
+ [ ResizeImage <$> smaller arbitrary
+ , Resize <$> smaller arbitrary
+ , pure ShrinkToMinimum
+ , pure KeepSize
+ ]
instance Arbitrary Partition where
arbitrary = oneof [Partition <$> elements [0, 1, 2], pure NoPT]
@@ -515,4 +503,4 @@
arbitrarySharedImageName :: Gen String
arbitrarySharedImageName =
- elements [printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3]]
+ elements [ printf "arbitrary-shared-img-name-%d" x | x <- [0 :: Int .. 3] ]
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
@@ -9,6 +9,7 @@
module B9.Environment
( Environment()
, fromStringPairs
+ , addBinding
, addStringBinding
, addLocalStringBinding
, addPositionalArguments
@@ -26,6 +27,7 @@
where
import B9.B9Error
+import B9.Text
import Control.Arrow ( (***) )
import Control.Exception ( Exception )
import Control.Eff as Eff
@@ -37,8 +39,6 @@
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.
@@ -100,7 +100,7 @@
(foldr
(\arg (MkEnvironment i e) -> MkEnvironment
(i + 1)
- (HashMap.insert (Text.pack ("arg_" ++ show i)) arg e)
+ (HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e)
)
)
@@ -108,45 +108,54 @@
-- | Convenient wrapper around 'addPositionalArguments' and 'localEnvironment'.
--
-- @since 0.5.65
-addLocalPositionalArguments :: Member EnvironmentReader e => [String] -> Eff e a -> Eff e a
+addLocalPositionalArguments
+ :: Member EnvironmentReader e => [String] -> Eff e a -> Eff e a
addLocalPositionalArguments extraPositional = localEnvironment appendVars
- where
- appendVars = addPositionalArguments (Text.pack <$> extraPositional)
+ where
+ appendVars = addPositionalArguments (unsafeRenderToText <$> 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
+ (unsafeRenderToText *** unsafeRenderToText)
--- | Insert a value into an 'Environment'. Thrown an exception when the
--- key already exists, and the value is different.
+-- | Insert a key value binding to the 'Environment'.
--
--- @since 0.5.62
-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
+-- Throw 'DuplicateKey' if the key already exists, but
+-- the value is not equal to the given value.
+--
+-- @since 0.5.67
+addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment
+addBinding (k, vNew) env =
+ let 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))
+-- | Insert 'String's into the 'Environment', see 'addBinding'.
+--
+-- @since 0.5.62
+addStringBinding
+ :: Member ExcB9 e => (String, String) -> Environment -> Eff e Environment
+addStringBinding = addBinding . (unsafeRenderToText *** unsafeRenderToText)
+
-- | Insert a value into an 'Environment' like 'addStringBinding',
-- but add it to the environment of the given effect, as in 'localEnvironment'.
--
-- @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
+ => (String, String)
+ -> Eff e a
+ -> Eff e a
+addLocalStringBinding binding action = do
+ e <- askEnvironment
+ e' <- addStringBinding binding e
+ localEnvironment (const e') action
-- | A monad transformer providing a 'MonadReader' instance for 'Environment'
--
@@ -224,9 +233,10 @@
instance Show KeyNotFound where
showsPrec _ (MkKeyNotFound key env) =
- let keys = unlines (Text.unpack <$> HashMap.keys (fromEnvironment env))
+ let keys =
+ unlines (unsafeParseFromText <$> HashMap.keys (fromEnvironment env))
in showString "Invalid template parameter: \""
- . showString (Text.unpack key)
+ . showString (unsafeParseFromText key)
. showString "\".\nValid variables:\n"
. showString keys
diff --git a/src/lib/B9/ExecEnv.hs b/src/lib/B9/ExecEnv.hs
--- a/src/lib/B9/ExecEnv.hs
+++ b/src/lib/B9/ExecEnv.hs
@@ -5,22 +5,23 @@
"B9.LibVirtLXC" should configure and execute
build scripts, as defined in "B9.ShellScript" and "B9.Vm".
-}
-module B9.ExecEnv (
- ExecEnv(..),
- Resources(..),
- noResources,
- SharedDirectory(..),
- CPUArch(..),
- RamSize(..),
- ) where
+module B9.ExecEnv
+ ( ExecEnv(..)
+ , Resources(..)
+ , noResources
+ , SharedDirectory(..)
+ , CPUArch(..)
+ , RamSize(..)
+ )
+where
-import Control.Parallel.Strategies
-import Data.Binary
-import Data.Data
-import Data.Hashable
-import Data.Semigroup as Sem
-import B9.DiskImages
-import GHC.Generics (Generic)
+import Control.Parallel.Strategies
+import Data.Binary
+import Data.Data
+import Data.Hashable
+import Data.Semigroup as Sem
+import B9.DiskImages
+import GHC.Generics ( Generic )
data ExecEnv = ExecEnv
{ envName :: String
@@ -57,11 +58,12 @@
instance NFData Resources
instance Sem.Semigroup Resources where
- (<>) (Resources m c a) (Resources m' c' a') = Resources (m <> m') (max c c') (a <> a')
+ (<>) (Resources m c a) (Resources m' c' a') =
+ Resources (m <> m') (max c c') (a <> a')
instance Monoid Resources where
- mempty = Resources mempty 1 mempty
- mappend = (Sem.<>)
+ mempty = Resources mempty 1 mempty
+ mappend = (Sem.<>)
noResources :: Resources
noResources = mempty
@@ -76,11 +78,11 @@
instance NFData CPUArch
instance Sem.Semigroup CPUArch where
- I386 <> x = x
+ I386 <> x = x
X86_64 <> _ = X86_64
instance Monoid CPUArch where
- mempty = I386
+ mempty = I386
mappend = (Sem.<>)
data RamSize
@@ -94,10 +96,10 @@
instance NFData RamSize
instance Sem.Semigroup RamSize where
- AutomaticRamSize <> x = x
- x <> AutomaticRamSize = x
- r <> r' = max r r'
+ AutomaticRamSize <> x = x
+ x <> AutomaticRamSize = x
+ r <> r' = max r r'
instance Monoid RamSize where
- mempty = AutomaticRamSize
+ mempty = AutomaticRamSize
mappend = (Sem.<>)
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
@@ -19,7 +19,9 @@
import B9.ShellScript
import Control.Eff
import Control.Lens ( view )
-import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Control.Monad.IO.Class ( MonadIO
+ , liftIO
+ )
import Data.Char ( toLower )
import System.Directory
import System.FilePath
@@ -54,9 +56,10 @@
scriptDirHost = buildDir "init-script"
scriptDirGuest = "/" ++ buildId
domainFile = buildBaseDir uuid' <.> domainConfig
- mkDomain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest
- uuid' = printf "%U" uuid
- setupEnv = Begin
+ mkDomain =
+ 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"]
@@ -81,8 +84,8 @@
virshCommand :: LibVirtLXCConfig -> String
virshCommand cfg = printf "%svirsh -c %s" useSudo' virshURI'
where
- useSudo' = if useSudo cfg then "sudo " else ""
- virshURI' = virshURI cfg
+ useSudo' = if useSudo cfg then "sudo " else ""
+ virshURI' = virshURI cfg
data Context =
Context FilePath
@@ -106,44 +109,44 @@
-> FilePath
-> m String
createDomain cfg e buildId uuid scriptDirHost scriptDirGuest = do
- emulatorPath <- getEmulatorPath cfg
- pure
- ( "\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 "
- ++ emulatorPath
- ++ "\n"
- ++ unlines
- ( libVirtNetwork (_networkId cfg)
- ++ (fsImage <$> envImageMounts e)
- ++ (fsSharedDir <$> envSharedDirectories e)
- )
- ++ "\n"
- ++ " \n \n \n \n \n \n \n \n\n"
- )
+ emulatorPath <- getEmulatorPath cfg
+ pure
+ ( "\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 "
+ ++ emulatorPath
+ ++ "\n"
+ ++ unlines
+ ( libVirtNetwork (_networkId cfg)
+ ++ (fsImage <$> envImageMounts e)
+ ++ (fsSharedDir <$> envSharedDirectories e)
+ )
+ ++ "\n"
+ ++ " \n \n \n \n \n \n \n \n\n"
+ )
renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
diff --git a/src/lib/B9/MBR.hs b/src/lib/B9/MBR.hs
--- a/src/lib/B9/MBR.hs
+++ b/src/lib/B9/MBR.hs
@@ -1,39 +1,42 @@
{-| Utility module to extract a primary partition from an MBR partition on a
raw image file. -}
-module B9.MBR ( getPartition
- , PrimaryPartition (..)
- , MBR(..)
- , CHS(..)) where
+module B9.MBR
+ ( getPartition
+ , PrimaryPartition(..)
+ , MBR(..)
+ , CHS(..)
+ )
+where
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Data.Binary.Get
-import Data.Word
-import Text.Printf
-import qualified Data.ByteString.Lazy as BL
+import Data.Binary.Get
+import Data.Word
+import Text.Printf
+import qualified Data.ByteString.Lazy as BL
getPartition :: Int -> FilePath -> IO (Word64, Word64)
getPartition n f = decodeMBR <$> BL.readFile f
- where
- decodeMBR input =
- let mbr = runGet getMBR input
- part =
- (case n of
- 1 -> mbrPart1
- 2 -> mbrPart2
- 3 -> mbrPart3
- 4 -> mbrPart4
- b ->
- error
- (printf
- "Error: Invalid partition index %i only partitions 1-4 are allowed. Image file: '%s'"
- b
- f))
- mbr
- start = fromIntegral (primPartLbaStart part)
- len = fromIntegral (primPartSectors part)
- in (start * sectorSize, len * sectorSize)
+ where
+ decodeMBR input =
+ let
+ mbr = runGet getMBR input
+ part =
+ (case n of
+ 1 -> mbrPart1
+ 2 -> mbrPart2
+ 3 -> mbrPart3
+ 4 -> mbrPart4
+ b -> error
+ (printf
+ "Error: Invalid partition index %i only partitions 1-4 are allowed. Image file: '%s'"
+ b
+ f
+ )
+ )
+ mbr
+ start = fromIntegral (primPartLbaStart part)
+ len = fromIntegral (primPartSectors part)
+ in
+ (start * sectorSize, len * sectorSize)
sectorSize :: Word64
sectorSize = 512
@@ -64,16 +67,18 @@
deriving Show
getMBR :: Get MBR
-getMBR = skip bootCodeSize >>
- MBR <$> getPart <*> getPart <*> getPart <*> getPart
+getMBR =
+ skip bootCodeSize >> MBR <$> getPart <*> getPart <*> getPart <*> getPart
getPart :: Get PrimaryPartition
-getPart = PrimaryPartition <$> getWord8
- <*> getCHS
- <*> getWord8
- <*> getCHS
- <*> getWord32le
- <*> getWord32le
+getPart =
+ PrimaryPartition
+ <$> getWord8
+ <*> getCHS
+ <*> getWord8
+ <*> getCHS
+ <*> getWord32le
+ <*> getWord32le
getCHS :: Get CHS
getCHS = CHS <$> getWord8 <*> getWord8 <*> getWord8
diff --git a/src/lib/B9/PartitionTable.hs b/src/lib/B9/PartitionTable.hs
--- a/src/lib/B9/PartitionTable.hs
+++ b/src/lib/B9/PartitionTable.hs
@@ -1,23 +1,20 @@
{-| Function to find the file offsets of primary partitions in raw disk
images. Currently only MBR partitions are supported. See 'B9.MBR' -}
-module B9.PartitionTable ( getPartition ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Data.Word ( Word64 )
+module B9.PartitionTable
+ ( getPartition
+ )
+where
-import qualified B9.MBR as MBR
+import Data.Word ( Word64 )
+import qualified B9.MBR as MBR
getPartition :: Int -> FilePath -> IO (Word64, Word64, Word64)
getPartition partitionIndex diskImage =
blockSized <$> MBR.getPartition partitionIndex diskImage
blockSized :: (Integral a) => (a, a) -> (a, a, a)
-blockSized (s, l) = let bs = gcd2 1 s l
- in (s `div` bs, l `div` bs, bs)
- where
- gcd2 n x y = let next = 2 * n in
- if x `rem` next == 0 && y `rem` next == 0
- then gcd2 next x y
- else n
+blockSized (s, l) = let bs = gcd2 1 s l in (s `div` bs, l `div` bs, bs)
+ where
+ gcd2 n x y =
+ let next = 2 * n
+ in if x `rem` next == 0 && y `rem` next == 0 then gcd2 next x y else n
diff --git a/src/lib/B9/QCUtil.hs b/src/lib/B9/QCUtil.hs
--- a/src/lib/B9/QCUtil.hs
+++ b/src/lib/B9/QCUtil.hs
@@ -3,15 +3,10 @@
-}
module B9.QCUtil where
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Monad
-import Test.QuickCheck
+import Control.Monad
+import Test.QuickCheck
-arbitraryEnv
- :: Arbitrary a
- => Gen [(String, a)]
+arbitraryEnv :: Arbitrary a => Gen [(String, a)]
arbitraryEnv = listOf ((,) <$> listOf1 (choose ('a', 'z')) <*> arbitrary)
halfSize :: Gen a -> Gen a
@@ -22,23 +17,23 @@
arbitraryFilePath :: Gen FilePath
arbitraryFilePath = do
- path <-
- join <$>
- listOf
- (elements
- [ "/"
- , "../"
- , "./"
- , "etc/"
- , "opt/"
- , "user/"
- , "var/"
- , "tmp/"
- , "doc/"
- , "share/"
- , "conf.d/"])
- prefix <- elements ["foo_", "", "alt_", "ssh-", ""]
- body <- elements ["www", "passwd", "cert", "opnsfe", "runtime"]
+ path <- join <$> listOf
+ (elements
+ [ "/"
+ , "../"
+ , "./"
+ , "etc/"
+ , "opt/"
+ , "user/"
+ , "var/"
+ , "tmp/"
+ , "doc/"
+ , "share/"
+ , "conf.d/"
+ ]
+ )
+ prefix <- elements ["foo_", "", "alt_", "ssh-", ""]
+ body <- elements ["www", "passwd", "cert", "opnsfe", "runtime"]
extension <- elements [".txt", ".png", ".ps", ".erl", ""]
return (path ++ prefix ++ body ++ extension)
diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs
--- a/src/lib/B9/Repository.hs
+++ b/src/lib/B9/Repository.hs
@@ -3,52 +3,55 @@
the whole thing is supposed to be build-server-safe, that means no two builds
shall interfere with each other. This is accomplished by refraining from
automatic cache updates from/to remote repositories.-}
-module B9.Repository (initRepoCache
- ,RepoCacheReader
- ,getRepoCache
- ,withRemoteRepos
- ,withSelectedRemoteRepo
- ,getSelectedRemoteRepo
- ,SelectedRemoteRepoReader
- ,SelectedRemoteRepo(..)
- ,initRemoteRepo
- ,cleanRemoteRepo
- ,remoteRepoCheckSshPrivKey
- ,remoteRepoCacheDir
- ,localRepoDir
- ,lookupRemoteRepo
- ,module X) where
+module B9.Repository
+ ( initRepoCache
+ , RepoCacheReader
+ , getRepoCache
+ , withRemoteRepos
+ , withSelectedRemoteRepo
+ , getSelectedRemoteRepo
+ , SelectedRemoteRepoReader
+ , SelectedRemoteRepo(..)
+ , initRemoteRepo
+ , cleanRemoteRepo
+ , remoteRepoCheckSshPrivKey
+ , remoteRepoCacheDir
+ , localRepoDir
+ , 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
+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
+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
+ :: (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)
+ 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.
--
@@ -72,19 +75,19 @@
=> Eff (SelectedRemoteRepoReader ': e) a
-> Eff e a
withSelectedRemoteRepo e = do
- remoteRepos' <- _remoteRepos <$> getB9Config
+ 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
+ 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'.
@@ -102,7 +105,8 @@
-- selected by the 'B9Config' value '_repository'. See 'withSelectedRemoteRepo'.
--
-- @since 0.5.65
-getSelectedRemoteRepo :: Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo
+getSelectedRemoteRepo
+ :: Member SelectedRemoteRepoReader e => Eff e SelectedRemoteRepo
getSelectedRemoteRepo = ask
-- | Initialize the local repository cache directory.
@@ -115,21 +119,19 @@
-- | Check for existance of priv-key and make it an absolute path.
remoteRepoCheckSshPrivKey :: MonadIO m => RemoteRepo -> m RemoteRepo
remoteRepoCheckSshPrivKey (RemoteRepo rId rp (SshPrivKey keyFile) h u) = do
- exists <- liftIO (doesFileExist keyFile)
+ exists <- liftIO (doesFileExist keyFile)
keyFile' <- liftIO (canonicalizePath keyFile)
- unless exists
- (error (printf "SSH Key file '%s' for repository '%s' is missing."
- keyFile'
- rId))
+ unless
+ exists
+ (error
+ (printf "SSH Key file '%s' for repository '%s' is missing." keyFile' rId)
+ )
return (RemoteRepo rId rp (SshPrivKey keyFile') h u)
-- | Initialize the repository; load the corresponding settings from the config
-- file, check that the priv key exists and create the correspondig cache
-- directory.
-initRemoteRepo :: MonadIO m
- => RepoCache
- -> RemoteRepo
- -> m RemoteRepo
+initRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m RemoteRepo
initRemoteRepo cache repo = do
-- TODO logging traceL $ printf "Initializing remote repo: %s" (remoteRepoRepoId repo)
repo' <- remoteRepoCheckSshPrivKey repo
@@ -140,12 +142,9 @@
-- | Empty the repository; load the corresponding settings from the config
-- file, check that the priv key exists and create the correspondig cache
-- directory.
-cleanRemoteRepo :: MonadIO m
- => RepoCache
- -> RemoteRepo
- -> m ()
+cleanRemoteRepo :: MonadIO m => RepoCache -> RemoteRepo -> m ()
cleanRemoteRepo cache repo = do
- let repoId = remoteRepoRepoId repo
+ let repoId = remoteRepoRepoId repo
repoDir = remoteRepoCacheDir cache repoId ++ "/"
-- TODO logging infoL $ printf "Cleaning remote repo: %s" repoId
ensureDir repoDir
@@ -155,22 +154,22 @@
-- | Return the cache directory for a remote repository relative to the root
-- cache dir.
-remoteRepoCacheDir :: RepoCache -- ^ The repository cache directory
- -> String -- ^ Id of the repository
- -> FilePath -- ^ The existing, absolute path to the
+remoteRepoCacheDir
+ :: RepoCache -- ^ The repository cache directory
+ -> String -- ^ Id of the repository
+ -> FilePath -- ^ The existing, absolute path to the
-- cache directory
remoteRepoCacheDir (RepoCache cacheDir) repoId =
cacheDir "remote-repos" repoId
-- | Return the local repository directory.
-localRepoDir :: RepoCache -- ^ The repository cache directory
- -> FilePath -- ^ The existing, absolute path to the
+localRepoDir
+ :: RepoCache -- ^ The repository cache directory
+ -> FilePath -- ^ The existing, absolute path to the
-- directory
-localRepoDir (RepoCache cacheDir) =
- cacheDir "local-repo"
+localRepoDir (RepoCache cacheDir) = cacheDir "local-repo"
-- | Select the first 'RemoteRepo' with a given @repoId@.
lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo
lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs
- where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid,r)) repos
-
+ where repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos
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
@@ -8,19 +8,20 @@
, Repository(..)
, toRemoteRepository
, FilePathGlob(..)
- ) where
+ )
+where
-import B9.B9Config (getRemoteRepos)
-import B9.B9Logging
-import B9.B9Exec
-import B9.Repository
-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)
+import B9.B9Config ( getRemoteRepos )
+import B9.B9Logging
+import B9.B9Exec
+import B9.Repository
+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
@@ -34,35 +35,36 @@
-- | 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 ::
- forall e. (CommandIO e, Member RepoCacheReader e)
+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 :: 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)
+ 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 :: (CommandIO e) => RemoteRepo -> FilePath -> FilePath -> Eff e ()
@@ -72,29 +74,43 @@
cmd (pushCmd repo src dest)
-- | Pull a file from a remote repository to cache
-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)
+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
+ )
-- | Push a file from the cache to a remote repository
-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
+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
+ ensureDir destDir
+ cmd c
-- | Express a pattern for file paths, used when searching repositories.
newtype FilePathGlob =
@@ -111,20 +127,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
+sshOpts (RemoteRepo _repoId _rootDir (SshPrivKey key) (SshRemoteHost (_host, port)) _user)
+ = unwords
[ "-o"
, "StrictHostKeyChecking=no"
, "-o"
diff --git a/src/lib/B9/Shake.hs b/src/lib/B9/Shake.hs
--- a/src/lib/B9/Shake.hs
+++ b/src/lib/B9/Shake.hs
@@ -1,6 +1,9 @@
-- | A module that re-exports all B9 Shake integration.
-- Which by the way is crude and preliminary...
-module B9.Shake (module X) where
+module B9.Shake
+ ( module X
+ )
+where
-import B9.Shake.Actions as X
-import B9.Shake.SharedImageRules as X
+import B9.Shake.Actions as X
+import B9.Shake.SharedImageRules as X
diff --git a/src/lib/B9/Shake/Actions.hs b/src/lib/B9/Shake/Actions.hs
--- a/src/lib/B9/Shake/Actions.hs
+++ b/src/lib/B9/Shake/Actions.hs
@@ -2,10 +2,11 @@
module B9.Shake.Actions
( b9InvocationAction
, buildB9File
- ) where
+ )
+where
import B9
-import Control.Lens ((?~))
+import Control.Lens ( (?~) )
import Development.Shake
-- | Convert a 'B9Invocation' action into a Shake 'Action'. This is just
@@ -24,4 +25,8 @@
need [f]
liftIO
(runB9ConfigAction
- (addLocalPositionalArguments args (localB9Config (projectRoot ?~ b9Root) (runBuildArtifacts [f]))))
+ (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,61 +4,71 @@
( customSharedImageAction
, needSharedImage
, enableSharedImageRules
- ) where
+ )
+where
-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
+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) =
- 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 = 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
+ 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 = 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'.
@@ -70,13 +80,19 @@
-- 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 <- 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
+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
diff --git a/src/lib/B9/ShellScript.hs b/src/lib/B9/ShellScript.hs
--- a/src/lib/B9/ShellScript.hs
+++ b/src/lib/B9/ShellScript.hs
@@ -1,26 +1,29 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-| Definition of 'Script' and functions to convert 'Script's to bash
scripts. -}
-module B9.ShellScript ( writeSh
- , renderScript
- , emptyScript
- , CmdVerbosity (..)
- , Cwd (..)
- , User (..)
- , Script (..)
- ) where
+module B9.ShellScript
+ ( writeSh
+ , renderScript
+ , emptyScript
+ , CmdVerbosity(..)
+ , Cwd(..)
+ , User(..)
+ , Script(..)
+ )
+where
-import Data.Data
-import Data.Semigroup as Sem
-import Control.Parallel.Strategies
-import Data.Binary
-import Data.Hashable
-import GHC.Generics (Generic)
-import Control.Monad.Reader
-import Data.List ( intercalate )
-import System.Directory ( getPermissions
- , setPermissions
- , setOwnerExecutable )
+import Data.Data
+import Data.Semigroup as Sem
+import Control.Parallel.Strategies
+import Data.Binary
+import Data.Hashable
+import GHC.Generics ( Generic )
+import Control.Monad.Reader
+import Data.List ( intercalate )
+import System.Directory ( getPermissions
+ , setPermissions
+ , setOwnerExecutable
+ )
data Script
= In FilePath
@@ -42,15 +45,15 @@
instance NFData Script
instance Sem.Semigroup Script where
- NoOP <> s = s
- s <> NoOP = s
+ NoOP <> s = s
+ s <> NoOP = s
(Begin ss) <> (Begin ss') = Begin (ss ++ ss')
- (Begin ss) <> s' = Begin (ss ++ [s'])
- s <> (Begin ss') = Begin (s : ss')
- s <> s' = Begin [s, s']
+ (Begin ss) <> s' = Begin (ss ++ [s'])
+ s <> (Begin ss') = Begin (s : ss')
+ s <> s' = Begin [s, s']
instance Monoid Script where
- mempty = NoOP
+ mempty = NoOP
mappend = (Sem.<>)
data Cmd =
@@ -121,36 +124,15 @@
toCmds s = runReader (toLLC s) (Ctx NoCwd NoUser False Debug)
where
toLLC :: Script -> Reader Ctx [Cmd]
- toLLC NoOP = return []
- toLLC (In d cs) =
- local
- (\ctx ->
- ctx
- { ctxCwd = Cwd d
- })
- (toLLC (Begin cs))
+ toLLC NoOP = return []
+ toLLC (In d cs) = local (\ctx -> ctx { ctxCwd = Cwd d }) (toLLC (Begin cs))
toLLC (As u cs) =
- local
- (\ctx ->
- ctx
- { ctxUser = User u
- })
- (toLLC (Begin cs))
+ local (\ctx -> ctx { ctxUser = User u }) (toLLC (Begin cs))
toLLC (IgnoreErrors b cs) =
- local
- (\ctx ->
- ctx
- { ctxIgnoreErrors = b
- })
- (toLLC (Begin cs))
+ local (\ctx -> ctx { ctxIgnoreErrors = b }) (toLLC (Begin cs))
toLLC (Verbosity v cs) =
- local
- (\ctx ->
- ctx
- { ctxVerbosity = v
- })
- (toLLC (Begin cs))
- toLLC (Begin cs) = concat <$> mapM toLLC cs
+ local (\ctx -> ctx { ctxVerbosity = v }) (toLLC (Begin cs))
+ toLLC (Begin cs ) = concat <$> mapM toLLC cs
toLLC (Run cmd args) = do
c <- reader ctxCwd
u <- reader ctxUser
@@ -169,31 +151,31 @@
cmdToBash :: Cmd -> String
cmdToBash (Cmd cmd args user cwd ignoreErrors verbosity) =
- intercalate "\n" $
- disableErrorChecking ++
- pushd cwdQ ++ execCmd ++ popd cwdQ ++ reenableErrorChecking
+ intercalate "\n"
+ $ disableErrorChecking
+ ++ pushd cwdQ
+ ++ execCmd
+ ++ popd cwdQ
+ ++ reenableErrorChecking
where
execCmd = [unwords (runuser ++ [cmd] ++ args ++ redirectOutput)]
where
- runuser =
- case user of
- NoUser -> []
- User "root" -> []
- User u -> ["runuser", "-p", "-u", u, "--"]
- pushd NoCwd = []
+ runuser = case user of
+ NoUser -> []
+ User "root" -> []
+ User u -> ["runuser", "-p", "-u", u, "--"]
+ pushd NoCwd = []
pushd (Cwd cwdPath) = [unwords (["pushd", cwdPath] ++ redirectOutput)]
popd NoCwd = []
popd (Cwd cwdPath) =
[unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath])]
- disableErrorChecking = ["set +e" | ignoreErrors]
- reenableErrorChecking = ["set -e" | ignoreErrors]
- cwdQ =
- case cwd of
- NoCwd -> NoCwd
- Cwd d -> Cwd ("'" ++ d ++ "'")
- redirectOutput =
- case verbosity of
- Debug -> []
- Verbose -> []
- OnlyStdErr -> [">", "/dev/null"]
- Quiet -> ["&>", "/dev/null"]
+ disableErrorChecking = [ "set +e" | ignoreErrors ]
+ reenableErrorChecking = [ "set -e" | ignoreErrors ]
+ cwdQ = case cwd of
+ NoCwd -> NoCwd
+ Cwd d -> Cwd ("'" ++ d ++ "'")
+ redirectOutput = case verbosity of
+ Debug -> []
+ Verbose -> []
+ OnlyStdErr -> [">", "/dev/null"]
+ Quiet -> ["&>", "/dev/null"]
diff --git a/src/lib/B9/Text.hs b/src/lib/B9/Text.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/B9/Text.hs
@@ -0,0 +1,146 @@
+{-# LANGUAGE TypeSynonymInstances,FlexibleInstances #-}
+-- | This module enables debugging all 'ByteString' to 'Text' to 'String' conversions.
+-- This is an internal module.
+--
+-- @since 0.5.67
+module B9.Text
+ ( Text
+ , LazyText
+ , ByteString
+ , LazyByteString
+ , Textual(..)
+ , writeTextFile
+ , unsafeRenderToText
+ , unsafeParseFromText
+ , parseFromTextWithErrorMessage
+ , encodeAsUtf8LazyByteString
+ )
+where
+
+import Data.ByteString ( ByteString )
+import Control.Exception ( displayException )
+-- import qualified Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as LazyByteString
+import qualified Data.Text as Text
+import Data.Text ( Text )
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Lazy as LazyText
+import qualified Data.Text.Lazy.Encoding as LazyText
+-- import qualified Data.Text.Encoding.Error as Text
+import Control.Monad.IO.Class
+import GHC.Stack
+
+-- | Lazy byte strings.
+--
+-- A type alias to 'Lazy.ByteString' that can be used everywhere such that
+-- references don't need to be qualified with the complete module name everywere.
+--
+-- @since 0.5.67
+type LazyByteString = LazyByteString.ByteString
+
+-- | Lazy texts.
+--
+-- A type alias to 'LazyText.Text' that can be used everywhere such that
+-- references don't need to be qualified with the complete module name everywere.
+--
+-- @since 0.5.67
+type LazyText = LazyText.Text
+
+-- | A class for values that can be converted to/from 'Text'.
+--
+-- @since 0.5.67
+class Textual a where
+ -- | Convert a 'String' to 'Text'
+ -- If an error occured, return 'Left' with the error message.
+ --
+ -- @since 0.5.67
+ renderToText :: HasCallStack => a -> Either String Text
+ -- | Convert a 'Text' to 'String'
+ --
+ -- @since 0.5.67
+ parseFromText :: HasCallStack => Text -> Either String a
+
+
+
+instance Textual Text where
+ renderToText = Right
+ parseFromText = Right
+
+instance Textual String where
+ renderToText = Right . Text.pack
+ parseFromText = Right . Text.unpack
+
+-- | Convert a 'ByteString' with UTF-8 encoded string to 'Text'
+--
+-- @since 0.5.67
+instance Textual ByteString where
+ renderToText x = case Text.decodeUtf8' x of
+ Left u -> Left
+ ( "renderToText of the ByteString failed: "
+ ++ displayException u
+ ++ " "
+ ++ show x
+ ++ "\nat:\n"
+ ++ prettyCallStack callStack
+ )
+ Right t -> Right t
+ parseFromText = Right . Text.encodeUtf8
+
+-- | Convert a 'LazyByteString' with UTF-8 encoded string to 'Text'
+--
+-- @since 0.5.67
+instance Textual LazyByteString where
+ renderToText x = case LazyText.decodeUtf8' x of
+ Left u -> Left
+ ( "renderToText of the LazyByteString failed: "
+ ++ displayException u
+ ++ " "
+ ++ show x
+ ++ "\nat:\n"
+ ++ prettyCallStack callStack
+ )
+ Right t -> Right (LazyText.toStrict t)
+ parseFromText = Right . LazyByteString.fromStrict . Text.encodeUtf8
+
+
+
+-- | Render a 'Text' to a file.
+--
+-- @since 0.5.67
+writeTextFile :: (HasCallStack, MonadIO m) => FilePath -> Text -> m ()
+writeTextFile f = liftIO . Text.writeFile f
+
+-- | Render a 'Text' via 'renderToText' and throw a runtime exception when rendering fails.
+--
+-- @since 0.5.67
+unsafeRenderToText :: (Textual a, HasCallStack) => a -> Text
+unsafeRenderToText = either error id . renderToText
+
+-- | Parse a 'Text' via 'parseFromText' and throw a runtime exception when parsing fails.
+--
+-- @since 0.5.67
+unsafeParseFromText :: (Textual a, HasCallStack) => Text -> a
+unsafeParseFromText = either error id . parseFromText
+
+-- | Encode a 'String' as UTF-8 encoded into a 'LazyByteString'.
+--
+-- @since 0.5.67
+encodeAsUtf8LazyByteString :: HasCallStack => String -> LazyByteString
+encodeAsUtf8LazyByteString =
+ LazyByteString.fromStrict . Text.encodeUtf8 . Text.pack
+
+-- | Parse the given 'Text'. \
+-- Return @Left errorMessage@ or @Right a@.
+--
+-- error message.
+--
+-- @since 0.5.67
+parseFromTextWithErrorMessage
+ :: (HasCallStack, Textual a)
+ => String -- ^ An arbitrary string for error messages
+ -> Text
+ -> Either String a
+parseFromTextWithErrorMessage errorMessage b = case parseFromText b of
+ Left e -> Left (unwords [errorMessage, e])
+ Right a -> Right a
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
@@ -50,15 +50,15 @@
gsubst = mkM substMountPoint `extM` substSharedDir `extM` substScript
substMountPoint NotMounted = pure NotMounted
- substMountPoint (MountPoint x) = MountPoint <$> subst x
+ substMountPoint (MountPoint x) = MountPoint <$> substStr x
substSharedDir (SharedDirectory fp mp) =
- SharedDirectory <$> subst fp <*> pure mp
+ SharedDirectory <$> substStr fp <*> pure mp
substSharedDir (SharedDirectoryRO fp mp) =
- SharedDirectoryRO <$> subst fp <*> pure mp
+ SharedDirectoryRO <$> substStr 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 (In fp s ) = In <$> substStr fp <*> pure s
+ substScript (Run fp args) = Run <$> substStr fp <*> mapM substStr args
+ substScript (As fp s ) = As <$> substStr 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
@@ -2,29 +2,33 @@
an execution environment like e.g. libvirt-lxc. -}
module B9.VmBuilder
( buildWithVm
- ) where
+ )
+where
-import Control.Eff
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.List
-import System.Directory (canonicalizePath, createDirectoryIfMissing)
-import Text.Printf (printf)
-import Text.Show.Pretty (ppShow)
+import Control.Eff
+import Control.Monad
+import Control.Monad.IO.Class
+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.BuildInfo
-import B9.DiskImageBuilder
-import B9.DiskImages
-import B9.ExecEnv
-import qualified B9.LibVirtLXC as LXC
-import B9.ShellScript
-import B9.Vm
+import B9.Artifact.Readable
+import B9.B9Config
+import B9.B9Logging
+import B9.B9Monad
+import B9.BuildInfo
+import B9.DiskImageBuilder
+import B9.DiskImages
+import B9.ExecEnv
+import qualified B9.LibVirtLXC as LXC
+import B9.ShellScript
+import B9.Vm
-buildWithVm :: IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool
+buildWithVm
+ :: IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool
buildWithVm iid imageTargets instanceDir vmScript = do
vmBuildSupportedImageTypes <- getVmScriptSupportedImageTypes vmScript
buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes
@@ -47,20 +51,25 @@
infoL "CREATED BUILD IMAGES"
traceL (ppShow buildImages)
return buildImages
- where
- createBuildImage (ImageTarget dest imageSource _mnt) = do
- buildDir <- getBuildDir
- destTypes <- preferredDestImageTypes imageSource
- let buildImgType =
- head (destTypes `intersect` preferredSourceImageTypes dest `intersect` vmBuildSupportedImageTypes)
- srcImg <- resolveImageSource imageSource
- let buildImg = changeImageFormat buildImgType (changeImageDirectory buildDir srcImg)
- buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg
- materializeImageSource imageSource buildImg
- return buildImgAbsolutePath
+ where
+ createBuildImage (ImageTarget dest imageSource _mnt) = do
+ buildDir <- getBuildDir
+ destTypes <- preferredDestImageTypes imageSource
+ let buildImgType = head
+ ( destTypes
+ `intersect` preferredSourceImageTypes dest
+ `intersect` vmBuildSupportedImageTypes
+ )
+ srcImg <- resolveImageSource imageSource
+ let buildImg =
+ changeImageFormat buildImgType (changeImageDirectory buildDir srcImg)
+ buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg
+ materializeImageSource imageSource buildImg
+ return buildImgAbsolutePath
-runVmScript ::
- forall e. IsB9 e
+runVmScript
+ :: forall e
+ . IsB9 e
=> InstanceId
-> [ImageTarget]
-> [Image]
@@ -78,35 +87,37 @@
then infoL "EXECUTED BUILD SCRIPT"
else errorL "BUILD SCRIPT FAILED"
return success
- where
- 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))
+ where
+ 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))
-createSharedDirs :: IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
+createSharedDirs
+ :: IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
createSharedDirs instanceDir = mapM createSharedDir
- where
- createSharedDir (SharedDirectoryRO d m) = do
- d' <- createAndCanonicalize d
- return $ SharedDirectoryRO d' m
- createSharedDir (SharedDirectory d m) = do
- d' <- createAndCanonicalize d
- return $ SharedDirectory d' m
- createSharedDir (SharedSources mp) = do
- d' <- createAndCanonicalize instanceDir
- return $ SharedDirectoryRO d' mp
- createAndCanonicalize d =
- liftIO $ do
- createDirectoryIfMissing True d
- canonicalizePath d
+ where
+ createSharedDir (SharedDirectoryRO d m) = do
+ d' <- createAndCanonicalize d
+ return $ SharedDirectoryRO d' m
+ createSharedDir (SharedDirectory d m) = do
+ d' <- createAndCanonicalize d
+ return $ SharedDirectory d' m
+ createSharedDir (SharedSources mp) = do
+ d' <- createAndCanonicalize instanceDir
+ return $ SharedDirectoryRO d' mp
+ createAndCanonicalize d = liftIO $ do
+ createDirectoryIfMissing True d
+ canonicalizePath d
createDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e ()
createDestinationImages buildImages imageTargets = do
dbgL "converting build- to output images"
- let pairsToConvert = buildImages `zip` (itImageDestination `map` imageTargets)
+ let pairsToConvert =
+ buildImages `zip` (itImageDestination `map` imageTargets)
traceL (ppShow pairsToConvert)
mapM_ (uncurry createDestinationImage) pairsToConvert
infoL "CONVERTED BUILD- TO OUTPUT IMAGES"
diff --git a/src/lib/Data/ConfigFile/B9Extras.hs b/src/lib/Data/ConfigFile/B9Extras.hs
--- a/src/lib/Data/ConfigFile/B9Extras.hs
+++ b/src/lib/Data/ConfigFile/B9Extras.hs
@@ -1,34 +1,30 @@
-{-# Language DeriveDataTypeable, ConstraintKinds #-}
+{-# Language DeriveDataTypeable, ConstraintKinds, ExplicitNamespaces #-}
{-| Extensions to 'Data.ConfigFile' and utility functions for dealing with
configuration in general and reading/writing files. -}
-module Data.ConfigFile.B9Extras ( addSectionCP
- , setShowCP
- , setCP
- , readCP
- , mergeCP
- , toStringCP
- , sectionsCP
- , emptyCP
- , type CPGet
- , type CPOptionSpec
- , type CPSectionSpec
- , type CPDocument
- , CPError()
- , readCPDocument
- , CPReadException(..)
- ) where
+module Data.ConfigFile.B9Extras
+ ( addSectionCP
+ , setShowCP
+ , setCP
+ , readCP
+ , mergeCP
+ , toStringCP
+ , sectionsCP
+ , emptyCP
+ , type CPGet
+ , type CPOptionSpec
+ , type CPSectionSpec
+ , type CPDocument
+ , CPError()
+ , readCPDocument
+ , CPReadException(..)
+ )
+where
-#if !MIN_VERSION_base(4,10,0)
-import Data.Monoid
-#endif
-import Data.Typeable
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Data.ConfigFile
-import Control.Exception
-import Control.Monad.Except
-import System.IO.B9Extras
+import Data.Typeable
+import Data.ConfigFile
+import Control.Exception
+import Control.Monad.Except
+import System.IO.B9Extras
-- * Aliases for functions and types from 'ConfigParser' in 'Data.ConfigFile'
@@ -42,22 +38,40 @@
type CPOptionSpec = OptionSpec
-- | An alias for 'setshow'.
-setShowCP :: (Show a, MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> a -> m CPDocument
+setShowCP
+ :: (Show a, MonadError CPError m)
+ => CPDocument
+ -> CPSectionSpec
+ -> CPOptionSpec
+ -> a
+ -> m CPDocument
setShowCP = setshow
-- | An alias for 'set'.
-setCP :: (MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> String -> m CPDocument
+setCP
+ :: (MonadError CPError m)
+ => CPDocument
+ -> CPSectionSpec
+ -> CPOptionSpec
+ -> String
+ -> m CPDocument
setCP = set
-- | An alias for 'get'.
-readCP :: (CPGet a, MonadError CPError m) => CPDocument -> CPSectionSpec -> CPOptionSpec -> m a
+readCP
+ :: (CPGet a, MonadError CPError m)
+ => CPDocument
+ -> CPSectionSpec
+ -> CPOptionSpec
+ -> m a
readCP = get
-- | An alias for 'Get_C'
type CPGet a = Get_C a
-- | An alias for 'add_section'.
-addSectionCP :: MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument
+addSectionCP
+ :: MonadError CPError m => CPDocument -> CPSectionSpec -> m CPDocument
addSectionCP = add_section
-- | An alias for 'merge'.
@@ -82,7 +96,7 @@
liftIO $ do
res <- readfile emptyCP cfgFilePath
case res of
- Left e -> throwIO (CPReadException cfgFilePath e)
+ Left e -> throwIO (CPReadException cfgFilePath e)
Right cp -> return cp
-- | An exception thrown by 'readCPDocument'.
diff --git a/src/lib/System/IO/B9Extras.hs b/src/lib/System/IO/B9Extras.hs
--- a/src/lib/System/IO/B9Extras.hs
+++ b/src/lib/System/IO/B9Extras.hs
@@ -1,29 +1,30 @@
-- | Some utilities to deal with IO in B9.
-module System.IO.B9Extras (SystemPath (..)
- , resolve
- , ensureDir
- , getDirectoryFiles
- , prettyPrintToFile
- , consult
- , ConsultException(..)
- , randomUUID
- , UUID()
- ) where
+module System.IO.B9Extras
+ ( SystemPath(..)
+ , resolve
+ , ensureDir
+ , getDirectoryFiles
+ , prettyPrintToFile
+ , consult
+ , ConsultException(..)
+ , randomUUID
+ , UUID()
+ )
+where
-import Data.Typeable
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative
-#endif
-import Control.Exception
-import Control.Monad.Except
-import System.Directory
-import Text.Read ( readEither )
-import System.Random ( randomIO )
-import Data.Word ( Word16, Word32 )
-import System.FilePath
-import Text.Printf
-import Data.Data
-import Text.Show.Pretty (ppShow)
+import Data.Typeable
+import Control.Exception
+import Control.Monad.Except
+import System.Directory
+import Text.Read ( readEither )
+import System.Random ( randomIO )
+import Data.Word ( Word16
+ , Word32
+ )
+import System.FilePath
+import Text.Printf
+import Data.Data
+import Text.Show.Pretty ( ppShow )
-- * Relative Paths
@@ -40,7 +41,7 @@
-- | Convert a 'SystemPath' to a 'FilePath'.
resolve :: MonadIO m => SystemPath -> m FilePath
-resolve (Path p) = return p
+resolve (Path p) = return p
resolve (InHomeDir p) = liftIO $ do
d <- getHomeDirectory
return $ d p
@@ -56,7 +57,7 @@
-- | Get all files from 'dir' that is get ONLY files not directories
getDirectoryFiles :: MonadIO m => FilePath -> m [FilePath]
getDirectoryFiles dir = do
- entries <- liftIO (getDirectoryContents dir)
+ entries <- liftIO (getDirectoryContents dir)
fileEntries <- mapM (liftIO . doesFileExist . (dir )) entries
return (snd <$> filter fst (fileEntries `zip` entries))
@@ -81,10 +82,8 @@
consult f = liftIO $ do
c <- readFile f
case readEither c of
- Left e ->
- throwIO $ ConsultException f e
- Right a ->
- return a
+ Left e -> throwIO $ ConsultException f e
+ Right a -> return a
-- | An 'Exception' thrown by 'consult' to indicate the file does not
-- contain a 'read'able String
@@ -102,17 +101,22 @@
instance PrintfArg UUID where
formatArg (UUID (a, b, c, d, e, f)) fmt
- | fmtChar (vFmt 'U' fmt) == 'U' =
- let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String)
- in formatString str (fmt { fmtChar = 's', fmtPrecision = Nothing })
- | otherwise = errorBadFormat $ fmtChar fmt
+ | fmtChar (vFmt 'U' fmt) == 'U'
+ = let str = (printf "%08x-%04x-%04x-%04x-%08x%04x" a b c d e f :: String)
+ in formatString str (fmt { fmtChar = 's', fmtPrecision = Nothing })
+ | otherwise
+ = errorBadFormat $ fmtChar fmt
-- | Generate a random 'UUID'.
randomUUID :: MonadIO m => m UUID
randomUUID = liftIO
- (UUID <$> ((,,,,,) <$> randomIO
- <*> randomIO
- <*> randomIO
- <*> randomIO
- <*> randomIO
- <*> randomIO))
+ ( UUID
+ <$> ( (,,,,,)
+ <$> randomIO
+ <*> randomIO
+ <*> randomIO
+ <*> randomIO
+ <*> randomIO
+ <*> randomIO
+ )
+ )
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,6 +1,7 @@
module B9.ArtifactGeneratorImplSpec
( spec
- ) where
+ )
+where
import B9.Artifact.Readable
import B9.Artifact.Readable.Interpreter
@@ -8,95 +9,146 @@
import B9.ExecEnv
import B9.ShellScript
import B9.Vm
-import Data.Text ()
+import Data.Text ( )
import Test.Hspec
spec :: Spec
-spec =
- describe "assemble" $ do
- 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 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 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 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 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 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 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 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 src = Let [("variable", "value")] [vmImagesArtifact "" [] (buildScript "${variable}")]
- expected = buildScript "value"
- (Right [IG _ _ (VmImages [] actual)]) = runArtifactGenerator mempty "" "" src
- in actual `shouldBe` expected
+spec = describe "assemble" $ do
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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)
+transientCOW fileName 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)
+shareCOW destName 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)
+liveInstallerCOWImage destName 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)
+localCOWImage destName 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)
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]]])
+buildScript arg = VmScript
+ X86_64
+ [SharedDirectory arg (MountPoint arg), SharedDirectoryRO arg NotMounted]
+ (As arg [In arg [Run arg [arg]]])
diff --git a/src/tests/B9/Content/ErlTermsSpec.hs b/src/tests/B9/Content/ErlTermsSpec.hs
--- a/src/tests/B9/Content/ErlTermsSpec.hs
+++ b/src/tests/B9/Content/ErlTermsSpec.hs
@@ -1,159 +1,193 @@
{-# LANGUAGE OverloadedStrings #-}
-module B9.Content.ErlTermsSpec (spec) where
+module B9.Content.ErlTermsSpec
+ ( spec
+ )
+where
-import Data.List
-import Test.Hspec
-import Test.QuickCheck
-import Data.Maybe
-import B9.Artifact.Content.ErlTerms
-import qualified Data.ByteString.Lazy.Char8 as Lazy
+import Data.List
+import Test.Hspec
+import Test.QuickCheck
+import Data.Maybe
+import B9.Artifact.Content.ErlTerms
+import B9.Text
spec :: Spec
spec = do
- describe "parseErlTerm" $ do
- it "parses a non-empty string"
- (parseErlTerm "test" "\"hello world\"."
- `shouldBe` Right (ErlString "hello world"))
-
- it "parses a string with escaped characters"
- (parseErlTerm "test" "\"\\b\\^A\"."
- `shouldBe` Right (ErlString "\b\^A"))
+ describe "parseErlTerm" $ do
+ it
+ "parses a non-empty string"
+ ( parseErlTerm "test" "\"hello world\"."
+ `shouldBe` Right (ErlString "hello world")
+ )
- it "parses a string with escaped octals: \\X"
- (parseErlTerm "test" "\"\\7\"."
- `shouldBe` Right (ErlString "\o7"))
+ it
+ "parses a string with escaped characters"
+ ( parseErlTerm "test" "\"\\b\\^A\"."
+ `shouldBe` Right (ErlString "\b\^A")
+ )
- it "parses a string with escaped octals: \\XY"
- (parseErlTerm "test" "\"\\73\"."
- `shouldBe` Right (ErlString "\o73"))
+ it "parses a string with escaped octals: \\X"
+ (parseErlTerm "test" "\"\\7\"." `shouldBe` Right (ErlString "\o7"))
- it "parses a string with escaped octals: \\XYZ"
- (parseErlTerm "test" "\"\\431\"."
- `shouldBe` Right (ErlString "\o431"))
+ it
+ "parses a string with escaped octals: \\XY"
+ (parseErlTerm "test" "\"\\73\"." `shouldBe` Right (ErlString "\o73"))
- it "parses a string with escaped hex: \\xNN"
- (parseErlTerm "test" "\"\\xbE\"."
- `shouldBe` Right (ErlString "\xbe"))
+ it
+ "parses a string with escaped octals: \\XYZ"
+ (parseErlTerm "test" "\"\\431\"." `shouldBe` Right (ErlString "\o431"))
- it "parses a string with escaped hex: \\x{N} (1)"
- (parseErlTerm "test" "\"\\x{a}\"."
- `shouldBe` Right (ErlString "\xa"))
+ it
+ "parses a string with escaped hex: \\xNN"
+ (parseErlTerm "test" "\"\\xbE\"." `shouldBe` Right (ErlString "\xbe"))
- it "parses a string with escaped hex: \\x{N} (2)"
- (parseErlTerm "test" "\"\\x{2}\"."
- `shouldBe` Right (ErlString "\x2"))
+ it
+ "parses a string with escaped hex: \\x{N} (1)"
+ (parseErlTerm "test" "\"\\x{a}\"." `shouldBe` Right (ErlString "\xa"))
- it "parses a two digit octal followed by a non-octal digit"
- (parseErlTerm "test" "\"\\779\"."
- `shouldBe` Right (ErlString "\o77\&9"))
+ it
+ "parses a string with escaped hex: \\x{N} (2)"
+ (parseErlTerm "test" "\"\\x{2}\"." `shouldBe` Right (ErlString "\x2"))
- it "parses a string with escaped hex: \\x{NNNNNN...}"
- (parseErlTerm "test" "\"\\x{000000Fa}\"."
- `shouldBe` Right (ErlString "\xfa"))
+ it
+ "parses a two digit octal followed by a non-octal digit"
+ ( parseErlTerm "test" "\"\\779\"."
+ `shouldBe` Right (ErlString "\o77\&9")
+ )
- it "parses decimal literals"
- (property
- (do decimal <- arbitrary `suchThat` (>= 0)
- let decimalStr = Lazy.pack (show (decimal :: Integer) ++ ".")
- parsedTerm <- case parseErlTerm "test" decimalStr of
- (Left e) -> fail e
- (Right parsedTerm) -> return parsedTerm
- return (ErlNatural decimal == parsedTerm)))
+ it
+ "parses a string with escaped hex: \\x{NNNNNN...}"
+ ( parseErlTerm "test" "\"\\x{000000Fa}\"."
+ `shouldBe` Right (ErlString "\xfa")
+ )
- it "parses a negative signed decimal"
- (parseErlTerm "test" "-1." `shouldBe` Right (ErlNatural (-1)))
+ it
+ "parses decimal literals"
+ (property
+ (do
+ decimal <- arbitrary `suchThat` (>= 0)
+ let decimalStr =
+ unsafeRenderToText (show (decimal :: Integer) ++ ".")
+ parsedTerm <- case parseErlTerm "test" decimalStr of
+ (Left e ) -> fail e
+ (Right parsedTerm) -> return parsedTerm
+ return (ErlNatural decimal == parsedTerm)
+ )
+ )
- it "parses a positive signed decimal"
- (parseErlTerm "test" "+1." `shouldBe` Right (ErlNatural 1))
+ it "parses a negative signed decimal"
+ (parseErlTerm "test" "-1." `shouldBe` Right (ErlNatural (-1)))
- it "parses decimal literals with radix notation"
- (property
- (do radix <- choose (2, 36)
- digitsInRadix <- listOf1 (choose (0, radix - 1))
- let (Right parsedTerm) = parseErlTerm "test" erlNumber
- erlNumber = Lazy.pack (show radix ++ "#" ++ digitChars ++ ".")
- expected = convertStrToDecimal radix digitChars
- digitChars = (naturals !!) <$> digitsInRadix
- return (ErlNatural expected == parsedTerm)))
+ it "parses a positive signed decimal"
+ (parseErlTerm "test" "+1." `shouldBe` Right (ErlNatural 1))
- it "parses a floating point literal with exponent and sign"
- (parseErlTerm "test" "-10.40E02." `shouldBe` Right (ErlFloat (-10.4e2)))
+ it
+ "parses decimal literals with radix notation"
+ (property
+ (do
+ radix <- choose (2, 36)
+ digitsInRadix <- listOf1 (choose (0, radix - 1))
+ let (Right parsedTerm) = parseErlTerm "test" erlNumber
+ erlNumber = unsafeRenderToText (show radix ++ "#" ++ digitChars ++ ".")
+ expected = convertStrToDecimal radix digitChars
+ digitChars = (naturals !!) <$> digitsInRadix
+ return (ErlNatural expected == parsedTerm)
+ )
+ )
- it "parses a simple erlang character literal"
- (parseErlTerm "test" "$ ." `shouldBe` Right (ErlChar (toEnum 32)))
+ it
+ "parses a floating point literal with exponent and sign"
+ (parseErlTerm "test" "-10.40E02." `shouldBe` Right (ErlFloat (-10.4e2))
+ )
- it "parses an erlang character literal with escape sequence"
- (parseErlTerm "test" "$\\x{Fe}." `shouldBe` Right (ErlChar (toEnum 254)))
+ it "parses a simple erlang character literal"
+ (parseErlTerm "test" "$ ." `shouldBe` Right (ErlChar (toEnum 32)))
- it "parses an unquoted atom with @ and _"
- (parseErlTerm "test" "a@0_T." `shouldBe` Right (ErlAtom "a@0_T"))
+ it
+ "parses an erlang character literal with escape sequence"
+ ( parseErlTerm "test" "$\\x{Fe}."
+ `shouldBe` Right (ErlChar (toEnum 254))
+ )
- it "parses a quoted atom with letters, spaces and special characters"
- (parseErlTerm "test" "' $s<\\\\.0_=@\\e\\''."
- `shouldBe` Right (ErlAtom " $s<\\.0_=@\ESC'"))
+ it "parses an unquoted atom with @ and _"
+ (parseErlTerm "test" "a@0_T." `shouldBe` Right (ErlAtom "a@0_T"))
- it "parses a binary literal containing a string"
- (parseErlTerm "test" "<<\"1 ok!\">>." `shouldBe` Right (ErlBinary "1 ok!"))
+ it
+ "parses a quoted atom with letters, spaces and special characters"
+ ( parseErlTerm "test" "' $s<\\\\.0_=@\\e\\''."
+ `shouldBe` Right (ErlAtom " $s<\\.0_=@\ESC'")
+ )
- it "parses an empty binary"
- (parseErlTerm "test" "<<>>." `shouldBe` Right (ErlBinary ""))
+ it
+ "parses a binary literal containing a string"
+ ( parseErlTerm "test" "<<\"1 ok!\">>."
+ `shouldBe` Right (ErlBinary "1 ok!")
+ )
- it "parses an empty list"
- (parseErlTerm "test" "[]." `shouldBe` Right (ErlList []))
+ it "parses an empty binary"
+ (parseErlTerm "test" "<<>>." `shouldBe` Right (ErlBinary ""))
- it "parses a list of atoms"
- (parseErlTerm "test" " [ hello, 'world' ] ." `shouldBe` Right (ErlList [ErlAtom "hello", ErlAtom "world"]))
+ it "parses an empty list"
+ (parseErlTerm "test" "[]." `shouldBe` Right (ErlList []))
- it "parses an empty tuple"
- (parseErlTerm "test" " { } ." `shouldBe` Right (ErlTuple []))
+ it
+ "parses a list of atoms"
+ ( parseErlTerm "test" " [ hello, 'world' ] ."
+ `shouldBe` Right (ErlList [ErlAtom "hello", ErlAtom "world"])
+ )
- it "parses a tuple of atoms"
- (parseErlTerm "test" " { hello, 'world' } ." `shouldBe` Right (ErlTuple [ErlAtom "hello", ErlAtom "world"]))
+ it "parses an empty tuple"
+ (parseErlTerm "test" " { } ." `shouldBe` Right (ErlTuple []))
- describe "renderErlTerm" $ do
- it "renders an empty binary as \"<<>>\"."
- (renderErlTerm (ErlBinary "") `shouldBe` "<<>>.")
+ it
+ "parses a tuple of atoms"
+ ( parseErlTerm "test" " { hello, 'world' } ."
+ `shouldBe` Right (ErlTuple [ErlAtom "hello", ErlAtom "world"])
+ )
- it "renders an erlang character"
- (renderErlTerm (ErlChar 'a') `shouldBe` "$a.")
+ describe "renderErlTerm" $ do
+ it "renders an empty binary as \"<<>>\"."
+ (renderErlTerm (ErlBinary "") `shouldBe` "<<>>.")
- it "renders a quoted atom and escapes special characters"
- (renderErlTerm (ErlAtom " $s\"<\\.0_=@\ESC'")
- `shouldBe` "' $s\"<\\\\.0_=@\\x{1b}\\''.")
+ it "renders an erlang character"
+ (renderErlTerm (ErlChar 'a') `shouldBe` "$a.")
- it "renders _ correctly as '_'"
- (renderErlTerm (ErlAtom "_")
- `shouldBe` "'_'.")
+ it
+ "renders a quoted atom and escapes special characters"
+ ( renderErlTerm (ErlAtom " $s\"<\\.0_=@\ESC'")
+ `shouldBe` "' $s\"<\\\\.0_=@\\x{1b}\\''."
+ )
- it "renders an empty string correctly as ''"
- (renderErlTerm (ErlAtom "")
- `shouldBe` "''.")
+ it "renders _ correctly as '_'"
+ (renderErlTerm (ErlAtom "_") `shouldBe` "'_'.")
- it "renders a string and escapes special characters"
- (renderErlTerm (ErlString "' $s\"<\\.0_=@\ESC''")
- `shouldBe` "\"' $s\\\"<\\\\.0_=@\\x{1b}''\".")
+ it "renders an empty string correctly as ''"
+ (renderErlTerm (ErlAtom "") `shouldBe` "''.")
- it "renders an empty list"
- (renderErlTerm (ErlList []) `shouldBe` "[].")
+ it
+ "renders a string and escapes special characters"
+ ( renderErlTerm (ErlString "' $s\"<\\.0_=@\ESC''")
+ `shouldBe` "\"' $s\\\"<\\\\.0_=@\\x{1b}''\"."
+ )
- it "renders an empty tuple"
- (renderErlTerm (ErlTuple []) `shouldBe` "{}.")
+ it "renders an empty list" (renderErlTerm (ErlList []) `shouldBe` "[].")
- describe "renderErlTerm and parseErlTerm" $
+ it "renders an empty tuple" (renderErlTerm (ErlTuple []) `shouldBe` "{}.")
- it "parseErlTerm parses all terms rendered by renderErlTerm"
- (property parsesRenderedTerms)
+ describe "renderErlTerm and parseErlTerm" $ it
+ "parseErlTerm parses all terms rendered by renderErlTerm"
+ (property parsesRenderedTerms)
parsesRenderedTerms :: SimpleErlangTerm -> Bool
parsesRenderedTerms term =
- either error (term ==) (parseErlTerm "test" (renderErlTerm term))
+ either error (term ==) (parseErlTerm "test" (renderErlTerm term))
naturals :: String
-naturals = ['0'..'9'] ++ ['a' .. 'z']
+naturals = ['0' .. '9'] ++ ['a' .. 'z']
convertStrToDecimal :: Int -> String -> Integer
convertStrToDecimal radix digitChars =
- let hornersMethod acc d = acc * radixHighPrecision + digitCharToInteger d
- digitCharToInteger d = toInteger $ fromJust $ elemIndex d naturals
- radixHighPrecision = toInteger radix
- in foldl hornersMethod 0 digitChars
+ let hornersMethod acc d = acc * radixHighPrecision + digitCharToInteger d
+ digitCharToInteger d = toInteger $ fromJust $ elemIndex d naturals
+ radixHighPrecision = toInteger radix
+ in foldl hornersMethod 0 digitChars
diff --git a/src/tests/B9/Content/ErlangPropListSpec.hs b/src/tests/B9/Content/ErlangPropListSpec.hs
--- a/src/tests/B9/Content/ErlangPropListSpec.hs
+++ b/src/tests/B9/Content/ErlangPropListSpec.hs
@@ -1,69 +1,65 @@
{-# LANGUAGE OverloadedStrings #-}
-module B9.Content.ErlangPropListSpec (spec) where
-
-import Data.List
-import Test.Hspec
-import Test.QuickCheck
-#if !MIN_VERSION_base(4,11,0)
-import Data.Semigroup
-#endif
-import Data.Text ()
-import qualified Data.Binary as Binary
+module B9.Content.ErlangPropListSpec
+ ( spec
+ )
+where
-import B9.Artifact.Content.ErlTerms
-import B9.Artifact.Content.ErlangPropList
-import B9.Artifact.Content.AST
+import Data.List
+import Test.Hspec
+import Test.QuickCheck
+import Data.Text ( )
+import B9.Text
+import B9.Artifact.Content.ErlTerms
+import B9.Artifact.Content.ErlangPropList
spec :: Spec
-spec =
- describe "ErlangPropList" $ do
+spec = describe "ErlangPropList" $ do
- it "decodeOrFail'" $
- let v = decodeOrFail' "" "ok."
- in v `shouldBe` Right (ErlangPropList (ErlAtom "ok"))
+ it "parseFromText"
+ $ let v = parseFromText "ok."
+ in v `shouldBe` Right (ErlangPropList (ErlAtom "ok"))
- it "Binary.encode" $
- let v = Binary.encode (ErlangPropList (ErlAtom "ok"))
- in v `shouldBe` "ok."
+ it "renterToText"
+ $ let v = renderToText (ErlangPropList (ErlAtom "ok"))
+ in v `shouldBe` Right "ok."
- it "combines primitives by putting them in a list" $
- let p1 = ErlangPropList (ErlList [ErlAtom "a"])
- p2 = ErlangPropList (ErlList [ErlNatural 123])
- combined = ErlangPropList
- (ErlList [ErlAtom "a"
- ,ErlNatural 123])
- in (p1 <> p2) `shouldBe` combined
+ it "combines primitives by putting them in a list"
+ $ let p1 = ErlangPropList (ErlList [ErlAtom "a"])
+ p2 = ErlangPropList (ErlList [ErlNatural 123])
+ combined = ErlangPropList (ErlList [ErlAtom "a", ErlNatural 123])
+ in (p1 <> p2) `shouldBe` combined
- it "combines a list and a primitve by extending the list" $
- let (Right l) = decodeOrFail' "" "[a,b,c]." :: Either String ErlangPropList
- (Right p) = decodeOrFail' "" "{ok,value}."
- (Right combined) = decodeOrFail' "" "[a,b,c,{ok,value}]."
- in l <> p `shouldBe` combined
+ it "combines a list and a primitve by extending the list"
+ $ let (Right l) =
+ parseFromText "[a,b,c]." :: Either String ErlangPropList
+ (Right p ) = parseFromText "{ok,value}."
+ (Right combined) = parseFromText "[a,b,c,{ok,value}]."
+ in l <> p `shouldBe` combined
- it "combines a primitve and a list by extending the list" $
- let (Right l) = decodeOrFail' "" "[a,b,c]." :: Either String ErlangPropList
- (Right p) = decodeOrFail' "" "{ok,value}."
- (Right combined) = decodeOrFail' "" "[{ok,value},a,b,c]."
- in p <> l `shouldBe` combined
+ it "combines a primitve and a list by extending the list"
+ $ let (Right l) =
+ parseFromText "[a,b,c]." :: Either String ErlangPropList
+ (Right p ) = parseFromText "{ok,value}."
+ (Right combined) = parseFromText "[{ok,value},a,b,c]."
+ in p <> l `shouldBe` combined
- it "merges lists with distinct elements to lists containing the elements of both lists" $
- let p1 = ErlangPropList
- (ErlList
- [ErlTuple [ErlAtom "k_p1"
- ,ErlList [ErlNatural 1]]])
- p2 = ErlangPropList
- (ErlList
- [ErlTuple [ErlAtom "k_p2"
- ,ErlList [ErlNatural 1]]])
- expected = ErlangPropList
- (ErlList
- [ErlTuple [ErlAtom "k_p1"
- ,ErlList [ErlNatural 1]]
- ,ErlTuple [ErlAtom "k_p2"
- ,ErlList [ErlNatural 1]]])
- in p1 <> p2 `shouldBe` expected
+ it
+ "merges lists with distinct elements to lists containing the elements of both lists"
+ $ let p1 = ErlangPropList
+ (ErlList [ErlTuple [ErlAtom "k_p1", ErlList [ErlNatural 1]]])
+ p2 = ErlangPropList
+ (ErlList [ErlTuple [ErlAtom "k_p2", ErlList [ErlNatural 1]]])
+ expected = ErlangPropList
+ (ErlList
+ [ ErlTuple [ErlAtom "k_p1", ErlList [ErlNatural 1]]
+ , ErlTuple [ErlAtom "k_p2", ErlList [ErlNatural 1]]
+ ]
+ )
+ in p1 <> p2 `shouldBe` expected
- it "merges two property lists into a prop list that has the lenght of the left + the right proplist - the number of entries sharing the same key" (property mergedPropListsHaveCorrectLength)
+ it
+ "merges two property lists into a prop list that has the lenght of the left + the right proplist - the number of entries sharing the same key"
+ (property mergedPropListsHaveCorrectLength)
data ErlPropListTestData =
ErlPropListTestData { plistLeft :: [SimpleErlangTerm]
@@ -73,38 +69,35 @@
mergedPropListsHaveCorrectLength :: ErlPropListTestData -> Bool
mergedPropListsHaveCorrectLength (ErlPropListTestData l r common) =
- let (ErlangPropList (ErlList merged)) =
- ErlangPropList (ErlList l) <> ErlangPropList (ErlList r)
- expectedLen = length l + length r - length common
- in length merged == expectedLen
+ let (ErlangPropList (ErlList merged)) =
+ ErlangPropList (ErlList l) <> ErlangPropList (ErlList r)
+ expectedLen = length l + length r - length common
+ in length merged == expectedLen
instance Arbitrary ErlPropListTestData where
arbitrary = do
- someKeys <- nub <$> listOf arbitraryPlistKey
- numLeftOnly <- choose (0, length someKeys - 1)
- let keysLeftOnly = take numLeftOnly someKeys
- numCommon <- choose (0, length someKeys - numLeftOnly - 1)
- let keysCommon = take numCommon (drop numLeftOnly someKeys)
- let keysRightOnly = drop (numLeftOnly + numCommon) someKeys
- let numRightOnly = length someKeys - numLeftOnly - numCommon
- valuesLeft <- vectorOf (numLeftOnly + numCommon) arbitraryPlistValue
- valuesRight <- vectorOf (numRightOnly + numCommon) arbitraryPlistValue
- return ErlPropListTestData {
- plistLeft = zipWith toPair (keysLeftOnly <> keysCommon) valuesLeft
- , plistRight = zipWith toPair (keysRightOnly <> keysCommon) valuesRight
- , commonKeys = keysCommon
- }
+ someKeys <- nub <$> listOf arbitraryPlistKey
+ numLeftOnly <- choose (0, length someKeys - 1)
+ let keysLeftOnly = take numLeftOnly someKeys
+ numCommon <- choose (0, length someKeys - numLeftOnly - 1)
+ let keysCommon = take numCommon (drop numLeftOnly someKeys)
+ let keysRightOnly = drop (numLeftOnly + numCommon) someKeys
+ let numRightOnly = length someKeys - numLeftOnly - numCommon
+ valuesLeft <- vectorOf (numLeftOnly + numCommon) arbitraryPlistValue
+ valuesRight <- vectorOf (numRightOnly + numCommon) arbitraryPlistValue
+ return ErlPropListTestData
+ { plistLeft = zipWith toPair (keysLeftOnly <> keysCommon) valuesLeft
+ , plistRight = zipWith toPair (keysRightOnly <> keysCommon) valuesRight
+ , commonKeys = keysCommon
+ }
where
- toPair a b = ErlTuple [a,b]
- arbitraryPlist = ErlList <$> listOf arbitraryPlistEntry
- arbitraryPlistEntry = toPair <$> arbitraryPlistKey
- <*> arbitraryPlistValue
- arbitraryPlistKey = arbitraryErlSimpleAtom
- arbitraryPlistValue = oneof [arbitraryLiteral
- ,arbitraryList
- ,arbitraryPlist
- ,arbitraryTuple]
- arbitraryTuple = ErlTuple <$> listOf arbitraryPlistValue
- arbitraryList = ErlList <$> listOf arbitraryPlistValue
- arbitraryLiteral =
- oneof [arbitraryPlistKey,arbitraryErlString,arbitraryErlNumber]
+ toPair a b = ErlTuple [a, b]
+ arbitraryPlist = ErlList <$> listOf arbitraryPlistEntry
+ arbitraryPlistEntry = toPair <$> arbitraryPlistKey <*> arbitraryPlistValue
+ arbitraryPlistKey = arbitraryErlSimpleAtom
+ arbitraryPlistValue =
+ oneof [arbitraryLiteral, arbitraryList, arbitraryPlist, arbitraryTuple]
+ arbitraryTuple = ErlTuple <$> listOf arbitraryPlistValue
+ arbitraryList = ErlList <$> listOf arbitraryPlistValue
+ arbitraryLiteral =
+ oneof [arbitraryPlistKey, arbitraryErlString, arbitraryErlNumber]
diff --git a/src/tests/B9/Content/YamlObjectSpec.hs b/src/tests/B9/Content/YamlObjectSpec.hs
--- a/src/tests/B9/Content/YamlObjectSpec.hs
+++ b/src/tests/B9/Content/YamlObjectSpec.hs
@@ -1,88 +1,108 @@
{-# LANGUAGE OverloadedStrings #-}
-module B9.Content.YamlObjectSpec (spec) where
+module B9.Content.YamlObjectSpec
+ ( spec
+ )
+where
-import Test.Hspec
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
-import Data.Text ()
-import Data.Yaml
+import Test.Hspec
+import Data.Text ( )
+import Data.Yaml
-import B9.Artifact.Content.YamlObject
-import B9.Artifact.Content.CloudConfigYaml
-import B9.Artifact.Content.AST
+import B9.Artifact.Content.YamlObject
+import B9.Artifact.Content.CloudConfigYaml
+import B9.Artifact.Content.AST
spec :: Spec
spec = do
- describe "YamlObject" $ do
+ describe "YamlObject" $ do
- it "combines primitives by putting them in an array" $
- let v1 = YamlObject (toJSON True)
- v2 = YamlObject (toJSON (123::Int))
- combined = YamlObject (array [toJSON True
- ,toJSON (123::Int)])
- in (v1 <> v2) `shouldBe` combined
+ it "combines primitives by putting them in an array"
+ $ let v1 = YamlObject (toJSON True)
+ v2 = YamlObject (toJSON (123 :: Int))
+ combined = YamlObject (array [toJSON True, toJSON (123 :: Int)])
+ in (v1 <> v2) `shouldBe` combined
- it "combines objects with disjunct keys to an object containing all properties" $
- let plist1 = YamlObject (object ["k1" .= Number 1])
- plist2 = YamlObject (object ["k2" .= Number 2])
- combined = YamlObject (object ["k1" .= Number 1
- ,"k2" .= Number 2])
- in (plist1 <> plist2) `shouldBe` combined
+ it
+ "combines objects with disjunct keys to an object containing all properties"
+ $ let
+ plist1 = YamlObject (object ["k1" .= Number 1])
+ plist2 = YamlObject (object ["k2" .= Number 2])
+ combined =
+ YamlObject (object ["k1" .= Number 1, "k2" .= Number 2])
+ in
+ (plist1 <> plist2) `shouldBe` combined
- it "combines arrays by concatenating them" $
- let v1 = YamlObject (array [toJSON ("x"::String)])
- v2 = YamlObject (array [toJSON ("y"::String)])
- combined = YamlObject (array [toJSON ("x"::String)
- ,toJSON ("y"::String)])
- in (v1 <> v2) `shouldBe` combined
+ it "combines arrays by concatenating them"
+ $ let
+ v1 = YamlObject (array [toJSON ("x" :: String)])
+ v2 = YamlObject (array [toJSON ("y" :: String)])
+ combined = YamlObject
+ (array [toJSON ("x" :: String), toJSON ("y" :: String)])
+ in
+ (v1 <> v2) `shouldBe` combined
- it "combines objects to a an object containing all disjunct entries and combined entries with the same keys" $
- let o1 = YamlObject (object ["k1" .= Number 1
- ,"k" .= Number 2])
- o2 = YamlObject (object ["k2" .= Number 3
- ,"k" .= Number 4])
- combined =
- YamlObject (object ["k1" .= Number 1
- ,"k2" .= Number 3
- ,"k" .= array [Number 2
- ,Number 4]])
- in (o1 <> o2) `shouldBe` combined
+ it
+ "combines objects to a an object containing all disjunct entries and combined entries with the same keys"
+ $ let
+ o1 = YamlObject (object ["k1" .= Number 1, "k" .= Number 2])
+ o2 = YamlObject (object ["k2" .= Number 3, "k" .= Number 4])
+ combined = YamlObject
+ (object
+ [ "k1" .= Number 1
+ , "k2" .= Number 3
+ , "k" .= array [Number 2, Number 4]
+ ]
+ )
+ in
+ (o1 <> o2) `shouldBe` combined
- describe "CloudConfigYaml" $ do
- it "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" $
- let ud1, ud2 :: CloudConfigYaml
- (Right ud1) = decodeOrFail' "" "#cloud-config\n\nwrite_files:\n - contents: |\n hello world!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - x y z\n"
- (Right ud2) = decodeOrFail' "" "#cloud-config\n\nwrite_files:\n - contents: |\n hello world2!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - a b c\n"
+ describe "CloudConfigYaml" $ do
+ it
+ "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each"
+ $ let
+ ud1, ud2 :: CloudConfigYaml
+ (Right ud1) = parseFromTextWithErrorMessage
+ ""
+ "#cloud-config\n\nwrite_files:\n - contents: |\n hello world!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - x y z\n"
+ (Right ud2) = parseFromTextWithErrorMessage
+ ""
+ "#cloud-config\n\nwrite_files:\n - contents: |\n hello world2!\n\n path: /sdf/xyz/filename.cfg\n owner: root:root\n\nruncmd:\n - a b c\n"
- ud = MkCloudConfigYaml $ YamlObject
- (object
- ["runcmd" .=
- array [toJSON ("x y z"::String)
- ,toJSON ("a b c"::String)]
- ,"write_files" .=
- array [object
- ["contents" .=
- toJSON ("hello world!\n"::String)
- ,"path" .=
- toJSON ("/sdf/xyz/filename.cfg"::String)
- ,"owner" .=
- toJSON ("root:root"::String)]
- ,object
- ["contents" .=
- toJSON ("hello world2!\n"::String)
- ,"path" .=
- toJSON ("/sdf/xyz/filename.cfg"::String)
- ,"owner" .=
- toJSON ("root:root"::String)]]])
- in ud1 <> ud2 `shouldBe` ud
+ ud = MkCloudConfigYaml $ YamlObject
+ (object
+ [ "runcmd" .= array
+ [toJSON ("x y z" :: String), toJSON ("a b c" :: String)]
+ , "write_files" .= array
+ [ object
+ [ "contents" .= toJSON ("hello world!\n" :: String)
+ , "path" .= toJSON ("/sdf/xyz/filename.cfg" :: String)
+ , "owner" .= toJSON ("root:root" :: String)
+ ]
+ , object
+ [ "contents" .= toJSON ("hello world2!\n" :: String)
+ , "path" .= toJSON ("/sdf/xyz/filename.cfg" :: String)
+ , "owner" .= toJSON ("root:root" :: String)
+ ]
+ ]
+ ]
+ )
+ in
+ ud1 <> ud2 `shouldBe` ud
- it "combines strings by appending them" $
- let o1 = MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("Hello"::String)])
- o2 = MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("World"::String)])
- combined =
- MkCloudConfigYaml $ YamlObject (object ["k" .= toJSON ("HelloWorld"::String)])
- in (o1 <> o2) `shouldBe` combined
+ it "combines strings by appending them"
+ $ let
+ o1 = MkCloudConfigYaml
+ $ YamlObject (object ["k" .= toJSON ("Hello" :: String)])
+ o2 = MkCloudConfigYaml
+ $ YamlObject (object ["k" .= toJSON ("World" :: String)])
+ combined =
+ MkCloudConfigYaml $ YamlObject
+ (object ["k" .= toJSON ("HelloWorld" :: String)])
+ in
+ (o1 <> o2) `shouldBe` combined
-- describe "fromAST YamlObject" $ do