b9 0.5.66 → 0.5.67
raw patch · 45 files changed
+3068/−2416 lines, 45 filesdep −semigroupsdep ~basedep ~bytestringPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: semigroups
Dependency ranges changed: base, bytestring
API changes (from Hackage documentation)
- B9: decodeOrFail' :: Binary a => String -> ByteString -> Either String a
- B9: type ByteStringGenerator = B9 ByteString
- B9.Artifact.Content: type ByteStringGenerator = B9 ByteString
- B9.Artifact.Content.AST: decodeOrFail' :: Binary a => String -> ByteString -> Either String a
- B9.Artifact.Content.CloudConfigYaml: instance Data.Binary.Class.Binary B9.Artifact.Content.CloudConfigYaml.CloudConfigYaml
- B9.Artifact.Content.ErlangPropList: instance Data.Binary.Class.Binary B9.Artifact.Content.ErlangPropList.ErlangPropList
- B9.Artifact.Content.Readable: instance B9.Artifact.Content.ToContentGenerator B9.Artifact.Content.Readable.Content Data.ByteString.Lazy.Internal.ByteString
- B9.Artifact.Content.YamlObject: instance Data.Binary.Class.Binary B9.Artifact.Content.YamlObject.YamlObject
+ B9: addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment
+ B9: class Textual a
+ B9: data ByteString
+ B9: data Text
+ B9: encodeAsUtf8LazyByteString :: HasCallStack => String -> LazyByteString
+ B9: parseFromText :: (Textual a, HasCallStack) => Text -> Either String a
+ B9: parseFromTextWithErrorMessage :: (HasCallStack, Textual a) => String -> Text -> Either String a
+ B9: renderToText :: (Textual a, HasCallStack) => a -> Either String Text
+ B9: stringToErlangAst :: String -> AST c ErlangPropList
+ B9: substStr :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
+ B9: textToErlangAst :: Text -> AST c ErlangPropList
+ B9: type ContentGenerator = B9 Text
+ B9: type ErlangAst = AST Content ErlangPropList
+ B9: type LazyByteString = ByteString
+ B9: type LazyText = Text
+ B9: unsafeParseFromText :: (Textual a, HasCallStack) => Text -> a
+ B9: unsafeRenderToText :: (Textual a, HasCallStack) => a -> Text
+ B9: writeTextFile :: (HasCallStack, MonadIO m) => FilePath -> Text -> m ()
+ B9.Artifact.Content: data Text
+ B9.Artifact.Content: type ContentGenerator = B9 Text
+ B9.Artifact.Content.AST: parseFromTextWithErrorMessage :: (HasCallStack, Textual a) => String -> Text -> Either String a
+ B9.Artifact.Content.CloudConfigYaml: instance B9.Text.Textual B9.Artifact.Content.CloudConfigYaml.CloudConfigYaml
+ B9.Artifact.Content.ErlangPropList: instance B9.Text.Textual B9.Artifact.Content.ErlangPropList.ErlangPropList
+ B9.Artifact.Content.ErlangPropList: stringToErlangAst :: String -> AST c ErlangPropList
+ B9.Artifact.Content.ErlangPropList: textToErlangAst :: Text -> AST c ErlangPropList
+ B9.Artifact.Content.Readable: instance B9.Artifact.Content.ToContentGenerator B9.Artifact.Content.Readable.Content
+ B9.Artifact.Content.Readable: type ErlangAst = AST Content ErlangPropList
+ B9.Artifact.Content.StringTemplate: substStr :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
+ B9.Artifact.Content.YamlObject: instance B9.Text.Textual B9.Artifact.Content.YamlObject.YamlObject
+ B9.Environment: addBinding :: Member ExcB9 e => (Text, Text) -> Environment -> Eff e Environment
+ B9.Text: class Textual a
+ B9.Text: data ByteString
+ B9.Text: data Text
+ B9.Text: encodeAsUtf8LazyByteString :: HasCallStack => String -> LazyByteString
+ B9.Text: instance B9.Text.Textual B9.Text.LazyByteString
+ B9.Text: instance B9.Text.Textual Data.ByteString.Internal.ByteString
+ B9.Text: instance B9.Text.Textual Data.Text.Internal.Text
+ B9.Text: instance B9.Text.Textual GHC.Base.String
+ B9.Text: parseFromText :: (Textual a, HasCallStack) => Text -> Either String a
+ B9.Text: parseFromTextWithErrorMessage :: (HasCallStack, Textual a) => String -> Text -> Either String a
+ B9.Text: renderToText :: (Textual a, HasCallStack) => a -> Either String Text
+ B9.Text: type LazyByteString = ByteString
+ B9.Text: type LazyText = Text
+ B9.Text: unsafeParseFromText :: (Textual a, HasCallStack) => Text -> a
+ B9.Text: unsafeRenderToText :: (Textual a, HasCallStack) => a -> Text
+ B9.Text: writeTextFile :: (HasCallStack, MonadIO m) => FilePath -> Text -> m ()
- B9: class ToContentGenerator c a
+ B9: class ToContentGenerator c
- B9: cloudConfigFileHeader :: ByteString
+ B9: cloudConfigFileHeader :: Text
- B9: fromAST :: (FromAST a, IsB9 e, ToContentGenerator c ByteString) => AST c a -> Eff e a
+ B9: fromAST :: (FromAST a, IsB9 e, ToContentGenerator c) => AST c a -> Eff e a
- B9: parseErlTerm :: String -> ByteString -> Either String SimpleErlangTerm
+ B9: parseErlTerm :: String -> Text -> Either String SimpleErlangTerm
- B9: readTemplateFile :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) => SourceFile -> Eff e ByteString
+ B9: readTemplateFile :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) => SourceFile -> Eff e Text
- B9: renderErlTerm :: SimpleErlangTerm -> ByteString
+ B9: renderErlTerm :: SimpleErlangTerm -> Text
- B9: subst :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
+ B9: subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text
- B9: toContentGenerator :: (ToContentGenerator c a, IsB9 e) => c -> Eff e a
+ B9: toContentGenerator :: (ToContentGenerator c, HasCallStack, IsB9 e) => c -> Eff e Text
- B9.Artifact.Content: class ToContentGenerator c a
+ B9.Artifact.Content: class ToContentGenerator c
- B9.Artifact.Content: toContentGenerator :: (ToContentGenerator c a, IsB9 e) => c -> Eff e a
+ B9.Artifact.Content: toContentGenerator :: (ToContentGenerator c, HasCallStack, IsB9 e) => c -> Eff e Text
- B9.Artifact.Content.AST: fromAST :: (FromAST a, IsB9 e, ToContentGenerator c ByteString) => AST c a -> Eff e a
+ B9.Artifact.Content.AST: fromAST :: (FromAST a, IsB9 e, ToContentGenerator c) => AST c a -> Eff e a
- B9.Artifact.Content.CloudConfigYaml: cloudConfigFileHeader :: ByteString
+ B9.Artifact.Content.CloudConfigYaml: cloudConfigFileHeader :: Text
- B9.Artifact.Content.ErlTerms: parseErlTerm :: String -> ByteString -> Either String SimpleErlangTerm
+ B9.Artifact.Content.ErlTerms: parseErlTerm :: String -> Text -> Either String SimpleErlangTerm
- B9.Artifact.Content.ErlTerms: renderErlTerm :: SimpleErlangTerm -> ByteString
+ B9.Artifact.Content.ErlTerms: renderErlTerm :: SimpleErlangTerm -> Text
- B9.Artifact.Content.StringTemplate: readTemplateFile :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) => SourceFile -> Eff e ByteString
+ B9.Artifact.Content.StringTemplate: readTemplateFile :: (MonadIO (Eff e), '[ExcB9, EnvironmentReader] <:: e) => SourceFile -> Eff e Text
- B9.Artifact.Content.StringTemplate: subst :: (Member ExcB9 e, Member EnvironmentReader e) => String -> Eff e String
+ B9.Artifact.Content.StringTemplate: subst :: (Member ExcB9 e, Member EnvironmentReader e) => Text -> Eff e Text
Files
- .travis.yml +2/−32
- CHANGELOG.md +20/−0
- b9.cabal +44/−75
- src/cli/Main.hs +238/−131
- src/lib/B9.hs +196/−153
- src/lib/B9/Artifact/Content.hs +10/−7
- src/lib/B9/Artifact/Content/AST.hs +3/−15
- src/lib/B9/Artifact/Content/CloudConfigYaml.hs +25/−27
- src/lib/B9/Artifact/Content/ErlTerms.hs +237/−209
- src/lib/B9/Artifact/Content/ErlangPropList.hs +31/−15
- src/lib/B9/Artifact/Content/Readable.hs +58/−47
- src/lib/B9/Artifact/Content/StringTemplate.hs +52/−58
- src/lib/B9/Artifact/Content/YamlObject.hs +70/−59
- src/lib/B9/Artifact/Readable.hs +38/−32
- src/lib/B9/Artifact/Readable/Interpreter.hs +312/−225
- src/lib/B9/Artifact/Readable/Source.hs +20/−14
- src/lib/B9/B9Config.hs +154/−95
- src/lib/B9/B9Config/Repository.hs +14/−12
- src/lib/B9/B9Exec.hs +45/−43
- src/lib/B9/B9Logging.hs +40/−29
- src/lib/B9/B9Monad.hs +22/−15
- src/lib/B9/BuildInfo.hs +74/−72
- src/lib/B9/DiskImageBuilder.hs +26/−15
- src/lib/B9/DiskImages.hs +111/−123
- src/lib/B9/Environment.hs +34/−24
- src/lib/B9/ExecEnv.hs +26/−24
- src/lib/B9/LibVirtLXC.hs +47/−44
- src/lib/B9/MBR.hs +43/−38
- src/lib/B9/PartitionTable.hs +11/−14
- src/lib/B9/QCUtil.hs +20/−25
- src/lib/B9/Repository.hs +69/−70
- src/lib/B9/RepositoryIO.hs +87/−65
- src/lib/B9/Shake.hs +6/−3
- src/lib/B9/Shake/Actions.hs +8/−3
- src/lib/B9/Shake/SharedImageRules.hs +72/−56
- src/lib/B9/ShellScript.hs +55/−73
- src/lib/B9/Text.hs +146/−0
- src/lib/B9/Vm.hs +6/−6
- src/lib/B9/VmBuilder.hs +67/−56
- src/lib/Data/ConfigFile/B9Extras.hs +47/−33
- src/lib/System/IO/B9Extras.hs +44/−40
- src/tests/B9/ArtifactGeneratorImplSpec.hs +123/−71
- src/tests/B9/Content/ErlTermsSpec.hs +147/−113
- src/tests/B9/Content/ErlangPropListSpec.hs +79/−86
- src/tests/B9/Content/YamlObjectSpec.hs +89/−69
.travis.yml view
@@ -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
CHANGELOG.md view
@@ -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:
b9.cabal view
@@ -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
src/cli/Main.hs view
@@ -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")+ )
src/lib/B9.hs view
@@ -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'
src/lib/B9/Artifact/Content.hs view
@@ -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
src/lib/B9/Artifact/Content/AST.hs view
@@ -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
src/lib/B9/Artifact/Content/CloudConfigYaml.hs view
@@ -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])
src/lib/B9/Artifact/Content/ErlTerms.hs view
@@ -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 '@']
src/lib/B9/Artifact/Content/ErlangPropList.hs view
@@ -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
src/lib/B9/Artifact/Content/Readable.hs view
@@ -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
src/lib/B9/Artifact/Content/StringTemplate.hs view
@@ -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
src/lib/B9/Artifact/Content/YamlObject.hs view
@@ -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)
src/lib/B9/Artifact/Readable.hs view
@@ -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]
src/lib/B9/Artifact/Readable/Interpreter.hs view
@@ -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)
src/lib/B9/Artifact/Readable/Source.hs view
@@ -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+ ]
src/lib/B9/B9Config.hs view
@@ -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
src/lib/B9/B9Config/Repository.hs view
@@ -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)
src/lib/B9/B9Exec.hs view
@@ -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
src/lib/B9/B9Logging.hs view
@@ -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 "
src/lib/B9/B9Monad.hs view
@@ -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+ )
src/lib/B9/BuildInfo.hs view
@@ -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
src/lib/B9/DiskImageBuilder.hs view
@@ -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
src/lib/B9/DiskImages.hs view
@@ -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] ]
src/lib/B9/Environment.hs view
@@ -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
src/lib/B9/ExecEnv.hs view
@@ -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.<>)
src/lib/B9/LibVirtLXC.hs view
@@ -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- ( "<domain type='lxc'>\n <name>"- ++ buildId- ++ "</name>\n <uuid>"- ++ uuid- ++ "</uuid>\n <memory unit='"- ++ memoryUnit cfg e- ++ "'>"- ++ memoryAmount cfg e- ++ "</memory>\n <currentMemory unit='"- ++ memoryUnit cfg e- ++ "'>"- ++ memoryAmount cfg e- ++ "</currentMemory>\n <vcpu placement='static'>"- ++ cpuCountStr e- ++ "</vcpu>\n <features>\n <capabilities policy='default'>\n "- ++ renderGuestCapabilityEntries cfg- ++ "\n </capabilities>\n </features>\n <os>\n <type arch='"- ++ osArch e- ++ "'>exe</type>\n <init>"- ++ scriptDirGuest- </> initScript- ++ "</init>\n </os>\n <clock offset='utc'/>\n <on_poweroff>destroy</on_poweroff>\n <on_reboot>restart</on_reboot>\n <on_crash>destroy</on_crash>\n <devices>\n <emulator>"- ++ emulatorPath- ++ "</emulator>\n"- ++ unlines- ( libVirtNetwork (_networkId cfg)- ++ (fsImage <$> envImageMounts e)- ++ (fsSharedDir <$> envSharedDirectories e)- )- ++ "\n"- ++ " <filesystem type='mount'>\n <source dir='"- ++ scriptDirHost- ++ "'/>\n <target dir='"- ++ scriptDirGuest- ++ "'/>\n </filesystem>\n <console>\n <target type='lxc' port='0'/>\n </console>\n </devices>\n</domain>\n"- )+ emulatorPath <- getEmulatorPath cfg+ pure+ ( "<domain type='lxc'>\n <name>"+ ++ buildId+ ++ "</name>\n <uuid>"+ ++ uuid+ ++ "</uuid>\n <memory unit='"+ ++ memoryUnit cfg e+ ++ "'>"+ ++ memoryAmount cfg e+ ++ "</memory>\n <currentMemory unit='"+ ++ memoryUnit cfg e+ ++ "'>"+ ++ memoryAmount cfg e+ ++ "</currentMemory>\n <vcpu placement='static'>"+ ++ cpuCountStr e+ ++ "</vcpu>\n <features>\n <capabilities policy='default'>\n "+ ++ renderGuestCapabilityEntries cfg+ ++ "\n </capabilities>\n </features>\n <os>\n <type arch='"+ ++ osArch e+ ++ "'>exe</type>\n <init>"+ ++ scriptDirGuest+ </> initScript+ ++ "</init>\n </os>\n <clock offset='utc'/>\n <on_poweroff>destroy</on_poweroff>\n <on_reboot>restart</on_reboot>\n <on_crash>destroy</on_crash>\n <devices>\n <emulator>"+ ++ emulatorPath+ ++ "</emulator>\n"+ ++ unlines+ ( libVirtNetwork (_networkId cfg)+ ++ (fsImage <$> envImageMounts e)+ ++ (fsSharedDir <$> envSharedDirectories e)+ )+ ++ "\n"+ ++ " <filesystem type='mount'>\n <source dir='"+ ++ scriptDirHost+ ++ "'/>\n <target dir='"+ ++ scriptDirGuest+ ++ "'/>\n </filesystem>\n <console>\n <target type='lxc' port='0'/>\n </console>\n </devices>\n</domain>\n"+ ) renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
src/lib/B9/MBR.hs view
@@ -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
src/lib/B9/PartitionTable.hs view
@@ -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
src/lib/B9/QCUtil.hs view
@@ -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)
src/lib/B9/Repository.hs view
@@ -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
src/lib/B9/RepositoryIO.hs view
@@ -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"
src/lib/B9/Shake.hs view
@@ -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
src/lib/B9/Shake/Actions.hs view
@@ -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]))+ )+ )
@@ -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
src/lib/B9/ShellScript.hs view
@@ -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"]
+ src/lib/B9/Text.hs view
@@ -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
src/lib/B9/Vm.hs view
@@ -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
src/lib/B9/VmBuilder.hs view
@@ -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"
src/lib/Data/ConfigFile/B9Extras.hs view
@@ -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'.
src/lib/System/IO/B9Extras.hs view
@@ -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+ )+ )
src/tests/B9/ArtifactGeneratorImplSpec.hs view
@@ -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]]])
src/tests/B9/Content/ErlTermsSpec.hs view
@@ -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
src/tests/B9/Content/ErlangPropListSpec.hs view
@@ -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]
src/tests/B9/Content/YamlObjectSpec.hs view
@@ -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