b9 0.5.13 → 0.5.14

raw patch · 28 files changed

+1174/−592 lines, 28 filesdep +hashabledep +parallelPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hashable, parallel

API changes (from Hackage documentation)

Files

• b9.cabal +42/−7
• src/cli/Main.hs +15/−44
• src/lib/B9/ArtifactGenerator.hs +39/−8
• src/lib/B9/ArtifactGeneratorImpl.hs +13/−23
• src/lib/B9/B9Config.hs +3/−1
• src/lib/B9/Builder.hs +0/−22
• src/lib/B9/ConfigUtils.hs +2/−0
• src/lib/B9/Content/AST.hs +68/−60
• src/lib/B9/Content/ErlTerms.hs +34/−19
• src/lib/B9/Content/ErlangPropList.hs +52/−36
• src/lib/B9/Content/Generator.hs +24/−13
• src/lib/B9/Content/StringTemplate.hs +51/−23
• src/lib/B9/Content/YamlObject.hs +59/−38
• src/lib/B9/DSL.hs +348/−0
• src/lib/B9/DiskImageBuilder.hs +85/−71
• src/lib/B9/DiskImages.hs +69/−15
• src/lib/B9/ExecEnv.hs +55/−22
• src/lib/B9/LibVirtLXC.hs +2/−30
• src/lib/B9/MBR.hs +19/−15
• src/lib/B9/PartitionTable.hs +2/−0
• src/lib/B9/QCUtil.hs +2/−0
• src/lib/B9/Repository.hs +2/−0
• src/lib/B9/RepositoryIO.hs +16/−22
• src/lib/B9/ShellScript.hs +142/−73
• src/lib/B9/Vm.hs +21/−16
• src/tests/B9/Content/ErlangPropListSpec.hs +3/−3
• src/tests/B9/Content/YamlObjectSpec.hs +5/−29
• src/tests/B9/DiskImagesSpec.hs +1/−2

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.13+version:             0.5.14  synopsis:            A tool and library for building virtual machine images. @@ -82,6 +82,7 @@                    , B9.Content.Generator                    , B9.Content.StringTemplate                    , B9.QCUtil+                   , B9.DSL   other-modules:   Paths_b9   -- other-extensions:   build-depends:     ConfigFile@@ -95,8 +96,10 @@                    , conduit-extra                    , directory                    , filepath+                   , hashable                    , mtl                    , time >= 1.5.0 && < 2+                   , parallel                    , parsec                    , pretty-show                    , pretty@@ -116,14 +119,22 @@   default-extensions: TupleSections                     , GeneralizedNewtypeDeriving                     , DeriveDataTypeable+                    , DeriveGeneric                     , RankNTypes                     , FlexibleContexts                     , GADTs+                    , DataKinds+                    , KindSignatures+                    , TypeFamilies+                    , DeriveFunctor+                    , TemplateHaskell+                    , StandaloneDeriving+                    , CPP   hs-source-dirs:    src/lib   default-language:  Haskell2010-  ghc-options:       -with-rtsopts=-N -Wall -fno-warn-unused-imports+  ghc-options:       -with-rtsopts=-N -Wall                      -fwarn-unused-binds -fno-warn-unused-do-bind-  if impl(ghc >= 7.8.2) && impl(ghc < 7.10)+  if impl(ghc >= 7.8.2) && impl(ghc <= 7.10)      ghc-options: -fno-warn-amp  executable b9c@@ -137,9 +148,21 @@                    , optparse-applicative   hs-source-dirs:    src/cli   default-language:  Haskell2010-  ghc-options:       -threaded -with-rtsopts=-N -Wall -fno-warn-unused-imports+  default-extensions: TupleSections+                    , GeneralizedNewtypeDeriving+                    , DeriveDataTypeable+                    , RankNTypes+                    , FlexibleContexts+                    , GADTs+                    , DataKinds+                    , KindSignatures+                    , TypeFamilies+                    , DeriveFunctor+                    , TemplateHaskell+                    , CPP+  ghc-options:       -threaded -with-rtsopts=-N -Wall                      -fwarn-unused-binds -fno-warn-unused-do-bind-  if impl(ghc >= 7.8.2) && impl(ghc < 7.10)+  if impl(ghc >= 7.8.2) && impl(ghc <= 7.10)      ghc-options: -fno-warn-amp  test-suite spec@@ -165,5 +188,17 @@                    , bytestring                    , text                    , semigroups-  if impl(ghc >= 7.8.2) && impl(ghc < 7.10)-     ghc-options: -fno-warn-amp+  default-extensions: TupleSections+                    , GeneralizedNewtypeDeriving+                    , DeriveDataTypeable+                    , RankNTypes+                    , FlexibleContexts+                    , GADTs+                    , DataKinds+                    , KindSignatures+                    , TypeFamilies+                    , DeriveFunctor+                    , TemplateHaskell+                    , CPP+  if impl(ghc >= 7.8.2) && impl(ghc <= 7.10)+     ghc-options: -fno-warn-amp -fno-warn-unused-do-bind

@@ -9,10 +9,12 @@ import Data.Maybe import Data.Version import Paths_b9-import Prelude                         hiding (catch) import System.Directory+import System.IO.Error                 hiding (isDoesNotExistErrorType)+#if !MIN_VERSION_base(4,8,0) import System.IO.Error                 hiding (catch)-+import Prelude                         hiding (catch)+#endif import B9  main :: IO ()@@ -30,15 +32,7 @@              (helper <*> (B9Options <$> 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\-                            \\n\-                            \Repository names passed to the command line are\-                            \ looked up in the B9 configuration file, which is\-                            \ per default located in: '~/.b9/b9.conf'" <>+                  "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'" <>               headerDoc (Just helpHeader)))   where     helpHeader =@@ -100,8 +94,7 @@             (if not (isJust (repository conf'))                  then do                      errorL-                         "No repository specified! \-                            \ Use '-r' to specify a repo BEFORE 'push'."+                         "No repository specified! Use '-r' to specify a repo BEFORE 'push'."                      return False                  else do                      pushSharedImageLatestVersion name@@ -239,9 +232,7 @@         Left er ->             error                 (printf-                     "Failed to add remote repo '%s'\-                     \ to b9 configuration. The \-                     \error was: \"%s\"."+                     "Failed to add remote repo '%s' to b9 configuration. The error was: \"%s\"."                      (show repo)                      (show er))         Right cpWithRepo -> writeB9Config cfgFile cpWithRepo@@ -342,54 +333,37 @@              "build"              (info                   (runBuildArtifacts <$> buildFileParser)-                  (progDesc-                       "Merge all build file and\-                                               \ generate all artifacts.")) <>+                  (progDesc "Merge all build file and generate all artifacts.")) <>          command              "run"              (info                   (runRun <$> sharedImageNameParser <*> many (strArgument idm))                   (progDesc-                       "Run a command on the lastest version of the\-                                        \ specified shared image. All modifications\-                                        \ are lost on exit.")) <>+                       "Run a command on the lastest version of the specified shared image. All modifications are lost on exit.")) <>          command              "push"              (info                   (runPush <$> sharedImageNameParser)                   (progDesc-                       "Push the lastest shared image\-                                        \ from cache to the selected \-                                        \ remote repository.")) <>+                       "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.")) <>+                       "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.")) <>+                       "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.")) <>+                       "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 runListSharedImages) (progDesc "List shared images.")) <>@@ -410,8 +384,7 @@     some         (strOption              (help-                  "Build file to load, specify multiple build\-                \ files (each witch '-f') to build them all in a single run." <>+                  "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" <>@@ -432,9 +405,7 @@      (SshPrivKey <$>       strArgument           (help-               "Path to the SSH private\-                                         \ key file used for \-                                         \ authorization." <>+               "Path to the SSH private key file used for  authorization." <>            metavar "SSH_PRIV_KEY_FILE")) <*>      (SshRemoteHost <$>       ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*>

@@ -10,10 +10,15 @@         getAssemblyOutputFiles)        where -+import Control.Parallel.Strategies+import Data.Binary import Data.Data+import Data.Hashable+import GHC.Generics (Generic)+#if !MIN_VERSION_base(4,8,0) import Data.Monoid import Control.Applicative+#endif import System.FilePath ((<.>), (</>))  import B9.DiskImages@@ -115,8 +120,12 @@       -- that is a unique, human readable string describing the       -- artifact to assemble.       EmptyArtifact-    deriving (Read,Show,Eq,Data,Typeable)+    deriving (Read,Show,Eq,Data,Typeable,Generic) +instance Hashable ArtifactGenerator+instance Binary ArtifactGenerator+instance NFData ArtifactGenerator+ instance Monoid ArtifactGenerator where     mempty = Let [] []     (Let [] []) `mappend` x = x@@ -158,13 +167,17 @@     -- ^ __Deprecated__ Concatenate the files generated by the     -- nested 'ArtifactSource's. The nested, generated files     -- are not written when they are concatenated.-    deriving (Read,Show,Eq,Data,Typeable)+    deriving (Read,Show,Eq,Data,Typeable,Generic) +instance Hashable ArtifactSource+instance Binary ArtifactSource+instance NFData ArtifactSource+ -- | Identify an artifact. __Deprecated__ TODO: B9 does not check if all -- instances IDs are unique. newtype InstanceId =     IID String-    deriving (Read,Show,Typeable,Data,Eq)+    deriving (Read,Show,Typeable,Data,Eq,NFData,Binary,Hashable)  -- | The variable containing the instance id. __Deprecated__ instanceIdKey :: String@@ -198,8 +211,12 @@                VmScript     -- ^ a set of VM-images that were created by executing a     -- build script on them.-    deriving (Read,Show,Typeable,Data,Eq)+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable ArtifactAssembly+instance Binary ArtifactAssembly+instance NFData ArtifactAssembly+ -- | A type representing the targets assembled by -- 'B9.ArtifactGeneratorImpl.assemble' from an 'ArtifactAssembly'. There is a -- list of 'ArtifactTarget's because e.g. a single 'CloudInit' can produce upto@@ -207,20 +224,32 @@ data AssembledArtifact =     AssembledArtifact InstanceId                       [ArtifactTarget]-    deriving (Read,Show,Typeable,Data,Eq)+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable AssembledArtifact+instance Binary AssembledArtifact+instance NFData AssembledArtifact+ data ArtifactTarget     = CloudInitTarget CloudInitType                       FilePath     | VmImagesTarget-    deriving (Read,Show,Typeable,Data,Eq)+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable ArtifactTarget+instance Binary ArtifactTarget+instance NFData ArtifactTarget+ data CloudInitType     = CI_ISO     | CI_VFAT     | CI_DIR-    deriving (Read,Show,Typeable,Data,Eq)+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable CloudInitType+instance Binary CloudInitType+instance NFData CloudInitType+ -- | Return the files that the artifact assembly consist of. getAssemblyOutputFiles :: ArtifactAssembly -> [FilePath] getAssemblyOutputFiles (VmImages ts _) =@@ -233,6 +262,8 @@       | t == CI_VFAT = [baseName <.> "vfat"]       | t == CI_DIR = [baseName </> "meta-data", baseName </> "user-data"]       | otherwise = []++ -- * QuickCheck instances  instance Arbitrary ArtifactGenerator where

@@ -124,10 +124,7 @@     then return (zip vars <$> valueSets)     else cgError             (printf-               "Error in 'Each' binding during artifact \-                           \generation in:\n '%s'.\n\nThe variable list\n\-                           \%s\n has %i entries, but this binding set\n%s\n\n\-                           \has a different number of entries!\n"+               "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)@@ -137,18 +134,17 @@                -> [(String, [String])]                -> CGParser [[(String, String)]] eachBindingSet g kvs = do-  checkInput-  return bindingSets-+    checkInput+    return bindingSets   where-    bindingSets = transpose [repeat k `zip` vs | (k, vs) <- kvs]-    checkInput = when (1 /= length (nub $ length . snd <$> kvs))-                   (cgError-                      (printf-                         "Error in 'Each' binding: \n%s\n\-                                       \All value lists must have the same\-                                       \length!"-                         (ppShow g)))+    bindingSets = transpose [repeat k `zip` vs | (k,vs) <- kvs]+    checkInput =+        when+            (1 /= length (nub $ length . snd <$> kvs))+            (cgError+                 (printf+                      "Error in 'Each' binding: \n%s\nAll value lists must have the same length!"+                      (ppShow g)))   writeInstanceGenerator :: InstanceId -> ArtifactAssembly -> CGParser ()@@ -185,7 +181,6 @@ execIGEnv :: InstanceGenerator CGEnv           -> Either String (InstanceGenerator [SourceGenerator]) execIGEnv (IG iid (CGEnv env sources) assembly) = IG iid <$> sourceGens <*> pure (substAssembly env assembly)-   where     sourceGens = join <$> mapM (toSourceGen env) sources @@ -365,15 +360,10 @@       let isoFile = outPath <.> "iso"           tmpFile = buildDir </> takeFileName isoFile       ensureDir tmpFile-      dbgL (printf "creating cloud init iso temp image '%s',\-                   \ destination file: '%s" tmpFile isoFile)+      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"+           "genisoimage -output '%s' -volid cidata -rock -d '%s' 2>&1"            tmpFile            instanceDir)       dbgL (printf "moving iso image '%s' to '%s'" tmpFile isoFile)

@@ -16,7 +16,6 @@                    , BuildVariables                    ) where -import Data.Monoid import Data.Maybe (fromMaybe) import Control.Monad import Control.Exception@@ -24,7 +23,10 @@ import Control.Monad.IO.Class import System.Directory import Text.Printf+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif+import Data.Monoid  import B9.ConfigUtils 

@@ -30,28 +30,6 @@ import Control.Monad.IO.Class import System.Directory -import B9.B9Monad-import B9.ConfigUtils-import B9.B9Config-import B9.ExecEnv-import B9.DiskImages-import B9.DiskImageBuilder-import B9.ShellScript-import B9.Repository-import B9.RepositoryIO-import B9.ArtifactGenerator-import B9.ArtifactGeneratorImpl-import B9.Vm-import B9.VmBuilder-import B9.QCUtil--import B9.Content.AST-import B9.Content.StringTemplate-import B9.Content.ErlTerms-import B9.Content.ErlangPropList-import B9.Content.YamlObject-import B9.Content.Generator- buildArtifacts :: ArtifactGenerator -> ConfigParser -> B9Config -> IO Bool buildArtifacts artifactGenerator cfgParser cliCfg =   withB9Config cfgParser cliCfg $ \cfg ->

@@ -24,7 +24,9 @@ import Data.Monoid import Data.Function ( on ) import Data.Typeable+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Control.Exception import Control.Monad.IO.Class import System.Directory

@@ -22,83 +22,91 @@                       , CanRender(..)                       ) where +import           Control.Parallel.Strategies+import           Data.Binary import qualified Data.ByteString as B-import Data.Semigroup-import Data.Data-import Control.Applicative-import Control.Monad.IO.Class-import Control.Monad.Reader+import           Data.Data+import           Data.Hashable+import           Data.Semigroup+import           GHC.Generics (Generic)+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+import           Control.Monad.IO.Class+import           Control.Monad.Reader -import B9.Content.StringTemplate+import           B9.Content.StringTemplate -import Test.QuickCheck-import B9.QCUtil+import           Test.QuickCheck+import           B9.QCUtil  -- | Types of values that can be parsed/rendered from/to 'ByteString's. This -- class is used as basis for the 'ASTish' class.-class (Semigroup a) => ConcatableSyntax a where-  -- Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@-  decodeSyntax :: FilePath -- ^ An arbitrary string for error messages that corresponds-                          -- to a possible input file.-               -> B.ByteString -- ^ The raw input to parse-               -> Either String a-  -- Generate a string representation of @a@-  encodeSyntax :: a -> B.ByteString+class (Semigroup a) => ConcatableSyntax a  where+    -- Parse a bytestring into an 'a', and return @Left errorMessage@ or @Right a@+    decodeSyntax+        :: FilePath -- ^ An arbitrary string for error messages that+        -> B.ByteString -- ^ The raw input to parse+        -> Either String a+    -- Generate a string representation of @a@+    encodeSyntax+        :: a -> B.ByteString  instance ConcatableSyntax B.ByteString where-  decodeSyntax _ = Right-  encodeSyntax   = id+    decodeSyntax _ = Right+    encodeSyntax = id  -- | Describe how to create structured content that has a tree-like syntactic -- structure, e.g. yaml, JSON and erlang-proplists. The first parameter defines -- a /context/ into which the 'AST' is embeded, -- e.g. B9.Content.Generator.Content'. The second parameter defines a specifix -- syntax, e.g 'B9.Content.ErlangPropList' that the 'AST' value generates.-data AST c a = ASTObj [(String, AST c a)] -- ^ Create an object similar to a-                                          -- Json object.-             | ASTArr [AST c a] -- ^ An array.-             | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very-                                  -- powerful tool that allows to combine-                                  -- several inputs in a smart and safe way,-                                  -- e.g. by merging the values of the same-                                  -- fields in yaml objects.-             | ASTEmbed c -- Embed some pure content.-             | ASTString String -- A string literal.-             | ASTParse SourceFile -- An 'AST' obtained from parsing a source-                                   -- file that contains a string corresponding-                                   -- to the type parameter @a@, e.g. 'YamlObject's-             | AST a -- Embed a literal @a@.-  deriving (Read, Show, Typeable, Data, Eq)+data AST c a+    = ASTObj [(String, AST c a)] -- ^ Create an object similar to a+                                 -- Json object.+    | ASTArr [AST c a] -- ^ An array.+    | ASTMerge [AST c a] -- ^ Merge the nested elements, this is a very+                         -- powerful tool that allows to combine+    |+      -- several inputs in a smart and safe way,+      -- e.g. by merging the values of the same+      -- fields in yaml objects.+      ASTEmbed c -- Embed some pure content.+    | ASTString String -- A string literal.+    | ASTParse SourceFile -- An 'AST' obtained from parsing a source+                          -- file that contains a string corresponding+    |+                -- to the type parameter @a@, e.g. 'YamlObject's+      AST a -- Embed a literal @a@.+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance (Hashable c, Hashable a) => Hashable (AST c a)+instance (Binary c, Binary a) => Binary (AST c a)+instance (NFData c, NFData a) => NFData (AST c a)++ -- | Types of values that describe content, that can be created from an 'AST'.-class (ConcatableSyntax a) => ASTish a where-  fromAST :: (CanRender c-            ,Applicative m-            ,Monad m-            ,MonadIO m-            ,MonadReader Environment m)-          => AST c a-          -> m a+class (ConcatableSyntax a) => ASTish a  where+    fromAST+        :: (CanRender c, Applicative m, Monad m, MonadIO m, MonadReader Environment m)+        => AST c a -> m a  -- | Types of values that can be /rendered/ into a 'ByteString'-class CanRender c where-  render :: (Functor m-           ,Applicative m-           ,MonadIO m-           ,MonadReader Environment m)-         => c-         -> m B.ByteString+class CanRender c  where+    render+        :: (Functor m, Applicative m, MonadIO m, MonadReader Environment m)+        => c -> m B.ByteString  instance (Arbitrary c, Arbitrary a) => Arbitrary (AST c a) where-  arbitrary = oneof [ASTObj <$> smaller (listOf ((,)-                                                 <$> arbitrary-                                                 <*> arbitrary))-                    ,ASTArr <$> smaller (listOf arbitrary)-                    ,ASTMerge <$> sized-                                    (\s -> resize (max 2 s)-                                                  (listOf (halfSize arbitrary)))-                    ,ASTEmbed <$> smaller arbitrary-                    ,ASTString <$> arbitrary-                    ,ASTParse <$> smaller arbitrary-                    ,AST <$> smaller arbitrary-                    ]+    arbitrary =+        oneof+            [ ASTObj <$> smaller (listOf ((,) <$> arbitrary <*> arbitrary))+            , ASTArr <$> smaller (listOf arbitrary)+            , ASTMerge <$>+              sized+                  (\s ->+                        resize (max 2 s) (listOf (halfSize arbitrary)))+            , ASTEmbed <$> smaller arbitrary+            , ASTString <$> arbitrary+            , ASTParse <$> smaller arbitrary+            , AST <$> smaller arbitrary]

@@ -9,30 +9,45 @@                            ,arbitraryErlFloat                            ,arbitraryErlNameChar) where -import Data.Data-import Data.Function+import           Control.Parallel.Strategies+import           Data.Binary import qualified Data.ByteString.Char8 as B-import Text.Parsec.ByteString-import Text.Parsec-import Test.QuickCheck-import Control.Applicative ((<$>), pure, (<*>))-import Text.Show.Pretty-import Control.Monad-import Text.Printf+import           Data.Data+import           Data.Function+import           Data.Hashable+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+-- #if !MIN_VERSION_base(4,8,0)+import           Control.Applicative hiding ((<|>), many)+-- #endif+import           Text.Show.Pretty+import           Control.Monad+import           Text.Printf import qualified Text.PrettyPrint as PP -import B9.QCUtil+import           B9.QCUtil  -- | Simplified Erlang term representation.-data SimpleErlangTerm = ErlString String-                      | ErlFloat Double-                      | ErlNatural Integer-                      | ErlAtom String-                      | ErlChar Char-                      | ErlBinary String-                      | ErlList [SimpleErlangTerm]-                      | ErlTuple [SimpleErlangTerm]-                      deriving (Eq,Ord,Read,Show,Data,Typeable)+data SimpleErlangTerm+    = ErlString String+    | ErlFloat Double+    | ErlNatural Integer+    | ErlAtom String+    | ErlChar Char+    | ErlBinary String+    | ErlList [SimpleErlangTerm]+    | ErlTuple [SimpleErlangTerm]+    deriving (Eq,Ord,Read,Show,Data,Typeable,Generic)++instance Hashable SimpleErlangTerm+instance Binary SimpleErlangTerm+instance NFData SimpleErlangTerm+  -- | Parse a subset of valid Erlang terms. It parses no maps and binaries are -- restricted to either empty binaries or binaries with a string. The input

@@ -3,27 +3,38 @@ module B9.Content.ErlangPropList ( ErlangPropList (..)                                  ) where -import Data.Data+import           Control.Parallel.Strategies+import           Data.Binary+import           Data.Data+import           Data.Function+import           Data.Hashable+import           Data.List (partition,sortBy)+import           Data.Semigroup import qualified Data.Text as T import qualified Data.Text.Encoding as E-import Data.Function-import Data.List (partition,sortBy)-import Data.Semigroup-import Control.Applicative-import Text.Printf+import           GHC.Generics (Generic)+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+import           Text.Printf -import B9.Content.ErlTerms-import B9.Content.AST-import B9.Content.StringTemplate+import           B9.Content.ErlTerms+import           B9.Content.AST+import           B9.Content.StringTemplate -import Test.QuickCheck+import           Test.QuickCheck  -- | A wrapper type around erlang terms with a Semigroup instance useful for -- combining sys.config files with OTP-application configurations in a list of -- the form of a proplist.-data ErlangPropList = ErlangPropList SimpleErlangTerm-  deriving (Read,Eq,Show,Data,Typeable)+data ErlangPropList =+    ErlangPropList SimpleErlangTerm+    deriving (Read,Eq,Show,Data,Typeable,Generic) +instance Hashable ErlangPropList+instance Binary ErlangPropList+instance NFData ErlangPropList+ instance Arbitrary ErlangPropList where   arbitrary = ErlangPropList <$> arbitrary @@ -80,27 +91,32 @@   encodeSyntax (ErlangPropList t)  = renderErlTerm t  instance ASTish ErlangPropList where-  fromAST (AST a) = pure a-  fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs-    where-      makePair (k, ast) = do-        (ErlangPropList second) <- fromAST ast-        return $ ErlTuple [ErlAtom k, second]-  fromAST (ASTArr xs) =-        ErlangPropList . ErlList-    <$> mapM (\x -> do (ErlangPropList x') <- fromAST x-                       return x')-             xs-  fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s-  fromAST (ASTEmbed c) =-    ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> render 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 decodeSyntax srcPath c of-      Right s -> return s-      Left e -> error (printf "could not parse erlang \-                              \source file: '%s'\n%s\n"-                              srcPath-                              e)+    fromAST (AST a) = pure a+    fromAST (ASTObj pairs) = ErlangPropList . ErlList <$> mapM makePair pairs+      where+        makePair (k,ast) = do+            (ErlangPropList second) <- fromAST ast+            return $ ErlTuple [ErlAtom k, second]+    fromAST (ASTArr xs) =+        ErlangPropList . ErlList <$>+        mapM+            (\x ->+                  do (ErlangPropList x') <- fromAST x+                     return x')+            xs+    fromAST (ASTString s) = pure $ ErlangPropList $ ErlString s+    fromAST (ASTEmbed c) =+        ErlangPropList . ErlString . T.unpack . E.decodeUtf8 <$> render 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 decodeSyntax srcPath c of+            Right s -> return s+            Left e ->+                error+                    (printf+                         "could not parse erlang source file: '%s'\n%s\n"+                         srcPath+                         e)

@@ -2,23 +2,34 @@     composable and addressable in B9 artifacts. -} module B9.Content.Generator where -import Data.Data-import Control.Applicative+import           Control.Parallel.Strategies+import           Data.Binary+import           Data.Data+import           Data.Hashable+import           GHC.Generics (Generic)+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif -import B9.Content.AST-import B9.Content.ErlangPropList-import B9.Content.StringTemplate-import B9.Content.YamlObject+import           B9.Content.AST+import           B9.Content.ErlangPropList+import           B9.Content.StringTemplate+import           B9.Content.YamlObject import qualified Data.ByteString.Char8 as B -import Test.QuickCheck-import B9.QCUtil+import           Test.QuickCheck+import           B9.QCUtil -data Content = RenderErlang (AST Content ErlangPropList)-             | RenderYaml (AST Content YamlObject)-             | FromString String-             | FromTextFile SourceFile-  deriving (Read, Show, Typeable, Eq, Data)+data Content+    = RenderErlang (AST Content ErlangPropList)+    | RenderYaml (AST Content YamlObject)+    | FromString String+    | FromTextFile SourceFile+    deriving (Read,Show,Typeable,Eq,Data,Generic)++instance Hashable Content+instance Binary Content+instance NFData Content  instance Arbitrary Content where   arbitrary = oneof [FromTextFile <$> smaller arbitrary

@@ -7,13 +7,19 @@         withEnvironment)        where +#if !MIN_VERSION_base(4,8,0) import           Control.Applicative+#endif import           Control.Arrow hiding (second) import           Control.Monad.Reader import           Data.Bifunctor import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB+import           Control.Parallel.Strategies+import           GHC.Generics (Generic)+import           Data.Binary import           Data.Data+import           Data.Hashable import           Data.Maybe import qualified Data.Text as T import           Data.Text.Encoding as E@@ -28,14 +34,28 @@ import           B9.QCUtil -- | A wrapper around a file path and a flag indicating if template variable -- expansion should be performed when reading the file contents.-data SourceFile = Source SourceFileConversion FilePath-    deriving (Read, Show, Typeable, Data, Eq)+data SourceFile =+    Source SourceFileConversion+           FilePath+    deriving (Read,Show,Typeable,Data,Eq,Generic) -data SourceFileConversion = NoConversion | ExpandVariables-  deriving (Read, Show, Typeable, Data, Eq)+instance Hashable SourceFile+instance Binary SourceFile+instance NFData SourceFile -data Environment = Environment [(String,String)]+data SourceFileConversion+    = NoConversion+    | ExpandVariables+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable SourceFileConversion+instance Binary SourceFileConversion+instance NFData SourceFileConversion++newtype Environment =+    Environment [(String, String)]+    deriving (Read,Show,Typeable,Data,Eq,NFData,Hashable,Binary)+ withEnvironment :: [(String,String)] -> ReaderT Environment m a -> m a withEnvironment env action = runReaderT action (Environment env) @@ -102,29 +122,37 @@  substFile :: MonadIO m => [(String, String)] -> FilePath -> FilePath -> m () substFile assocs src dest = do-  templateBs <- liftIO (B.readFile src)-  let t = templateSafe (E.decodeUtf8 templateBs)-  case t of-    Left (r,c) ->-      let badLine = unlines (take r (lines (T.unpack (E.decodeUtf8 templateBs))))-          colMarker = replicate (c - 1) '-' ++ "^"-      in error (printf "Template error in file '%s' line %i:\n\n%s\n%s\n"-                       src r badLine colMarker)-    Right template' -> do-      let out = LE.encodeUtf8 (render template' envLookup)-      liftIO (LB.writeFile dest out)-      return ()+    templateBs <- liftIO (B.readFile src)+    let t = templateSafe (E.decodeUtf8 templateBs)+    case t of+        Left (r,c) ->+            let badLine =+                    unlines+                        (take r (lines (T.unpack (E.decodeUtf8 templateBs))))+                colMarker = replicate (c - 1) '-' ++ "^"+            in error+                   (printf+                        "Template error in file '%s' line %i:\n\n%s\n%s\n"+                        src+                        r+                        badLine+                        colMarker)+        Right template' -> do+            let out = LE.encodeUtf8 (render template' envLookup)+            liftIO (LB.writeFile dest out)+            return ()   where     envT :: [(T.Text, T.Text)]     envT = (T.pack *** T.pack) <$> assocs     envLookup :: T.Text -> T.Text     envLookup x = fromMaybe (err x) (lookup x envT)-    err x = error (printf "Invalid template parameter: '%s'\n\-                          \In file: '%s'\n\-                          \Valid variables:\n%s\n"-                          (T.unpack x)-                          src-                          (ppShow assocs))+    err x =+        error+            (printf+                 "Invalid template parameter: '%s'\nIn file: '%s'\n Valid variables:\n%s\n"+                 (T.unpack x)+                 src+                 (ppShow assocs))  substPath :: [(String, String)] -> SystemPath -> SystemPath substPath assocs src =

@@ -4,15 +4,20 @@                              ) where  import           Control.Applicative+import           Control.Parallel.Strategies+import           Data.Binary (Binary(..)) import           Data.Data import           Data.Function-import           Data.HashMap.Strict       hiding (singleton)+import           Data.HashMap.Strict hiding (singleton)+import           Data.Hashable+import           Data.Maybe import           Data.Semigroup-import qualified Data.Text                 as T-import qualified Data.Text.Encoding        as E-import           Data.Vector               ((++), singleton)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import           Data.Vector ((++), singleton) import           Data.Yaml-import           Prelude                   hiding ((++))+import           GHC.Generics (Generic)+import           Prelude hiding ((++)) import           Text.Printf  import           B9.Content.AST@@ -22,9 +27,20 @@  -- | A wrapper type around yaml values with a Semigroup instance useful for -- combining yaml documents describing system configuration like e.g. user-data.-data YamlObject = YamlObject Data.Yaml.Value-  deriving (Eq, Data, Typeable)+data YamlObject =+    YamlObject Data.Yaml.Value+    deriving (Eq,Data,Typeable,Generic) +instance Hashable YamlObject+instance Binary YamlObject+instance NFData YamlObject++instance Binary Data.Yaml.Value where+  put = put . encode+  get = do+    v <- get+    return $ fromJust $ decode v+ instance Read YamlObject where   readsPrec _ = readsYamlObject     where@@ -73,37 +89,42 @@     E.encodeUtf8 (T.pack "#cloud-config\n") <> encode o  instance ASTish 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 . T.unpack . E.decodeUtf8 <$> render c-      ASTString str ->-        return (YamlObject (toJSON str))-      ASTParse src@(Source _ srcPath) -> do-        c <- readTemplateFile src-        case decodeSyntax 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' = T.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 . T.unpack . E.decodeUtf8 <$> render c+            ASTString str -> return (YamlObject (toJSON str))+            ASTParse src@(Source _ srcPath) -> do+                c <- readTemplateFile src+                case decodeSyntax 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' = T.pack key+            return $ key' .= o   instance Arbitrary YamlObject where

@@ -0,0 +1,348 @@+-- | Experimental new, hopefully typesafe. domain specific language for+--   description of VM-builds.+{-# LANGUAGE FlexibleInstances #-}+module B9.DSL+       (B9DSL, doc, doc', (#), Documentation(..), ($=), include, includeTemplate, writeContent,+        exportCloudInit, imageSource, createImage, importImage, from,+        fromResized, imageDestination, share, exportLiveInstallerImage,+        exportImage, mount, lxc, lxc32, boot, exec, sh, rootImage,+        dataImage, mountAndShareSharedImage, mountAndShareNewImage, runDSL,+        printDSL, printBuildStep, dslExample)+       where++import B9.ArtifactGenerator (ArtifactSource(..), CloudInitType(..))+import B9.B9Config (ExecEnvType(..))+import B9.Content.Generator(Content)+import B9.Content.StringTemplate+       (SourceFile(..), SourceFileConversion(..))+import B9.DiskImages+       (Image(..), ImageSource(..), ImageDestination(..), FileSystem(..),+        Partition(..), ImageResize(..), ImageSize(..), ImageType(..),+        SizeUnit(..))+import B9.ExecEnv (CPUArch(..), SharedDirectory(..))+import B9.ShellScript (Script(..))+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Monoid+import Control.Monad+#endif+import Control.Monad.Free (Free(..), liftF, foldFree)+import Data.Functor (void)+import Text.Printf (printf)++data BuildStep next :: * where+        Let :: String -> String -> next -> BuildStep next+        Import ::+          SArtifact a -> Source a -> (Imported a -> next) -> BuildStep next+        Export :: SArtifact a -> Target a -> next -> BuildStep next+        DefineExecEnv ::+          String ->+            ExecEnvType -> CPUArch -> (ExecEnv -> next) -> BuildStep next+        Exec :: ExecEnv -> Script -> next -> BuildStep next++instance Functor BuildStep where+    fmap f (Let k v next) = Let k v (f next)+    fmap f (Import sa src k) = Import sa src (f . k)+    fmap f (Export sa dst next) = Export sa dst (f next)+    fmap f (DefineExecEnv n et a k) = DefineExecEnv n et a (f . k)+    fmap f (Exec et s next) = Exec et s (f next)++type B9DSL a = Free BuildStep a++data Tagged a b =+    Tagged b++instance Show b => Show (Tagged a b) where+    show (Tagged s) = show s++data Documentation+    = Doc String+    | DocIncluded Content++data ExecEnv =+    ExecEnv String+            ExecEnvType+            CPUArch+    deriving (Show)++type family Source (a :: Artifact) :: * where+        Source 'StaticContent = ArtifactSource+        Source 'VmImage = ImageSource+        Source 'MountedImage = (ExecEnv, Tagged ImageSource String, FilePath)+        Source 'MountedHostDirectory = (ExecEnv, FilePath, FilePath, MountOpts String)+        Source 'SelfDocumentation = Documentation++type family Imported (a :: Artifact) :: * where+        Imported 'VmImage = Tagged ImageSource String+        Imported a = ()++type family Target (a :: Artifact) :: * where+        Target 'VmImage = (Tagged ImageSource String, ImageDestination)+        Target 'CloudInit = ([CloudInitType], FilePath)++data Artifact+    = StaticContent+    | VmImage+    | MountedImage+    | CloudInit+    | MountedHostDirectory+    | SelfDocumentation++data SArtifact (k :: Artifact) where+        SStaticContent :: SArtifact 'StaticContent+        SVmImage :: SArtifact 'VmImage+        SMountedImage :: SArtifact 'MountedImage+        SCloudInit :: SArtifact 'CloudInit+        SMountedHostDirectory :: SArtifact 'MountedHostDirectory+        SSelfDocumentation :: SArtifact 'SelfDocumentation++-- * For documentation of the actual build/deployment itself either embed a+--   string or a file, template parameters e.g. ${xxx} can be also used.++doc :: String -> B9DSL ()+doc str = liftF $ Import SSelfDocumentation (Doc str) id++doc' :: Content -> B9DSL ()+doc' c = liftF $ Import SSelfDocumentation (DocIncluded c) id++(#) :: B9DSL a -> String -> B9DSL a+m # str = do+  doc str+  m++-- * Content generation and static file inclusion++($=) :: String -> String -> B9DSL ()+var $= val = liftF $ Let var val ()++-- TODO split file inclusion from file content generation. i.e. add newFile+-- ... and then add an 'appendFile' function. new file should be typed according+-- to its contents so that only compatible content can be appended++include :: FilePath -> FilePath -> B9DSL ()+include dest src = liftF $ Import SStaticContent (FromFile dest (Source NoConversion src)) id++includeTemplate :: FilePath -> FilePath -> B9DSL ()+includeTemplate dest src = liftF $ Import SStaticContent (FromFile dest (Source ExpandVariables src)) id++writeContent :: FilePath -> Content -> B9DSL ()+writeContent dst src = liftF $ Import SStaticContent (FromContent dst src) id++-- * cloud init++exportCloudInit :: FilePath -> B9DSL ()+exportCloudInit dst = liftF $ Export SCloudInit ([CI_ISO, CI_DIR], dst) ()++-- * Image import++imageSource :: ImageSource -> B9DSL (Imported 'VmImage)+imageSource src = liftF $ Import SVmImage src id++createImage :: String+           -> FileSystem+           -> ImageType+           -> ImageSize+           -> B9DSL (Imported 'VmImage)+createImage s fs it is = imageSource $ EmptyImage s fs it is++importImage :: FilePath+             -> ImageType+             -> FileSystem+             -> Partition+             -> ImageResize+             -> B9DSL (Imported 'VmImage)+importImage f it fs pt is = imageSource $ SourceImage (Image f it fs) pt is++from :: String -> B9DSL (Imported 'VmImage)+from = fromResized KeepSize++fromResized :: ImageResize -> String -> B9DSL (Imported 'VmImage)+fromResized r s = imageSource $ From s r++-- * Image export++imageDestination :: Imported 'VmImage+                 -> ImageDestination+                 -> B9DSL ()+imageDestination img dst = liftF $ Export SVmImage (img, dst) ()++share :: Imported 'VmImage -> String -> B9DSL ()+share img name = imageDestination img $ Share name QCow2 KeepSize++exportLiveInstallerImage :: Imported 'VmImage+                         -> String+                         -> FilePath+                         -> ImageResize+                         -> B9DSL ()+exportLiveInstallerImage img imgName outDir resize =+    imageDestination img $ LiveInstallerImage imgName outDir resize++exportImage :: Imported 'VmImage+            -> FilePath+            -> ImageType+            -> FileSystem+            -> ImageResize+            -> B9DSL ()+exportImage img name it fs resize =+    imageDestination img $ LocalFile (Image name it fs) resize++-- * Mounting++class DSLCanMount a  where+    type MountArtifact a :: Artifact+    data MountOpts a+    defaultMountOpts :: a -> MountOpts a+    mountArtifactS :: a -> SArtifact (MountArtifact a)+    mountArtifact :: MountOpts a+                  -> ExecEnv+                  -> a+                  -> FilePath+                  -> Source (MountArtifact a)++-- * Host directory+instance DSLCanMount String where+  type MountArtifact String = 'MountedHostDirectory+  data MountOpts String = ReadOnly | ReadWrite deriving Show+  defaultMountOpts _ = ReadOnly+  mountArtifactS _ = SMountedHostDirectory+  mountArtifact opts e src dest = (e, src, dest, opts)++instance DSLCanMount (Tagged ImageSource String) where+  type MountArtifact (Tagged ImageSource String) = 'MountedImage+  data MountOpts (Tagged ImageSource String) = MountImgNoOptions deriving Show+  defaultMountOpts _ = MountImgNoOptions+  mountArtifactS _ = SMountedImage+  mountArtifact opts e src dest = (e, src, dest)++mount+    :: DSLCanMount src+    => ExecEnv -> src -> FilePath -> B9DSL (Imported (MountArtifact src))+mount = mount' (defaultMountOpts undefined)++mount'+    :: DSLCanMount src+    => MountOpts src+    -> ExecEnv+    -> src+    -> FilePath+    -> B9DSL (Imported (MountArtifact src))+mount' mopts e src dest =+    liftF $+    Import+        (mountArtifactS src)+        (mountArtifact mopts e src dest)+        id++-- * Execution environment++lxc :: String -> B9DSL ExecEnv+lxc name = boot name LibVirtLXC X86_64++lxc32 :: String -> B9DSL ExecEnv+lxc32 name = boot name LibVirtLXC I386++boot :: String -> ExecEnvType -> CPUArch -> B9DSL ExecEnv+boot name et arch = liftF $ DefineExecEnv name et arch id++-- * Script Execution (inside a container)++exec :: Script -> ExecEnv -> B9DSL ()+exec script e = liftF $ Exec e script ()++sh :: String -> ExecEnv -> B9DSL ()+sh s = exec (Run s [])++-- TODO generalize exec to work with 'includedFiles'++-- * Some utility vm builder lego++rootImage :: String -> String -> ExecEnv -> B9DSL ()+rootImage nameFrom nameExport env =+    void $ mountAndShareSharedImage nameFrom nameExport "/" env++dataImage :: String -> ExecEnv -> B9DSL ()+dataImage nameExport env =+    void $ mountAndShareNewImage "data" 64 nameExport "/data" env++mountAndShareSharedImage :: String -> String -> String -> ExecEnv -> B9DSL (Imported 'VmImage)+mountAndShareSharedImage nameFrom nameExport mountPoint env = do+    img <- from nameFrom+    share img nameExport+    mount env img mountPoint+    return img++mountAndShareNewImage :: String -> Int -> String -> FilePath -> ExecEnv -> B9DSL (Imported 'VmImage)+mountAndShareNewImage fsLabel sizeGB nameExport mountPoint env = do+    img <- createImage fsLabel Ext4 QCow2 (ImageSize sizeGB GB)+    share img nameExport+    mount env img mountPoint+    return img++-- * DSL Interpreter++#if MIN_VERSION_base(4,8,0)+runDSL+    :: Monad m+    => (forall a. BuildStep a -> m a) -> B9DSL b -> m b+#else+runDSL+    :: (Monad m, Functor m)+    => (forall a. BuildStep a -> m a) -> B9DSL b -> m b+#endif+runDSL = foldFree++-- | Print the DSL to IO+printDSL :: B9DSL a -> IO ()+printDSL = void . runDSL printBuildStep++printBuildStep :: BuildStep a -> IO a+printBuildStep (Let k v next) = do+    printf "%s := %s\n" k v+    return next+printBuildStep (Import SStaticContent src k) = do+    printf "import static %s\n" (show src)+    return $ k ()+printBuildStep (Import SVmImage src k) = do+    printf "import image %s\n" (show src)+    return (k (Tagged (show src)))+printBuildStep (Import SMountedImage src k) = do+    printf "mount image %s\n" (show src)+    return (k ())+printBuildStep (Import SMountedHostDirectory src k) = do+    printf "mount host directory %s\n" (show src)+    return (k ())+printBuildStep (Import SSelfDocumentation (Doc str) k) = do+    printf "-- %s\n" str+    return (k ())+printBuildStep (Import SSelfDocumentation (DocIncluded c) k) = do+    printf "-- %s\n" (show c)+    return (k ())+printBuildStep (Export SVmImage dst next) = do+    printf "export image %s\n" (show dst)+    return next+printBuildStep (Export SCloudInit dst next) = do+    printf "export cloud-init %s\n" (show dst)+    return next+printBuildStep (DefineExecEnv n et a k) = do+    printf "define env: %s %s %s\n" n (show et) (show a)+    return (k (ExecEnv n et a))+printBuildStep (Exec (ExecEnv n _ _) s next) = do+    printf "exec in %s: %s\n" n (show s)+    return next+printBuildStep _other = do+    printf "???\n"+    return undefined++-- * Tests and experiments++dslExample :: B9DSL ()+dslExample = do+    "x" $= "3"+    includeTemplate "httpd.conf" "httpd.conf.in" # "overwrite all of httpd!"+    exportCloudInit "blah-ci"                    # "export the cloud-init stuff"+    e <- lxc "container-id"+    doc "From here there be dragons:"+    mount e "/tmp" "/mnt/HOST_TMP"+    rootImage "fedora" "testv1-root" e+    dataImage "testv1-data" e+    sh "ls -la" e

@@ -154,62 +154,67 @@  createImageFromImage :: Image -> Partition -> ImageResize -> Image -> B9 () createImageFromImage src part size out = do-  importImage src out-  extractPartition part out-  resizeImage size out-+    importImage src out+    extractPartition part out+    resizeImage size out   where     extractPartition :: Partition -> Image -> B9 ()     extractPartition NoPT _ = return ()     extractPartition (Partition partIndex) (Image outFile Raw _) = do-      (start, len, blockSize) <- liftIO (P.getPartition partIndex outFile)-      let tmpFile = outFile <.> "extracted"-      dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)-      cmd-        (printf-           "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"-           outFile-           tmpFile-           blockSize-           start-           len)-      cmd (printf "mv '%s' '%s'" tmpFile outFile)+        (start,len,blockSize) <- liftIO (P.getPartition partIndex outFile)+        let tmpFile = outFile <.> "extracted"+        dbgL (printf "Extracting partition %i from '%s'" partIndex outFile)+        cmd+            (printf+                 "dd if='%s' of='%s' bs=%i skip=%i count=%i &> /dev/null"+                 outFile+                 tmpFile+                 blockSize+                 start+                 len)+        cmd (printf "mv '%s' '%s'" tmpFile outFile)     extractPartition (Partition partIndex) (Image outFile fmt _) =-      error-        (printf "Extract partition %i from \-                \image '%s': Invalid format %s" partIndex outFile-           (imageFileExtension fmt))+        error+            (printf+                 "Extract partition %i from image '%s': Invalid format %s"+                 partIndex+                 outFile+                 (imageFileExtension fmt))  createDestinationImage :: Image -> ImageDestination -> B9 () createDestinationImage buildImg dest =-  case dest of-    (Share name imgType imgResize) -> do-      resizeImage imgResize buildImg-      let shareableImg = changeImageFormat imgType buildImg-      exportAndRemoveImage buildImg shareableImg-      void (shareImage shareableImg (SharedImageName name))-    (LocalFile destImg imgResize) -> do-      resizeImage imgResize buildImg-      exportAndRemoveImage buildImg destImg-    (LiveInstallerImage name repo imgResize) -> do-      resizeImage imgResize buildImg-      let destImg = Image destFile Raw buildImgFs-          (Image _ _ buildImgFs) = buildImg-          destFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.raw"-          sizeFile = repo </> "machines" </> name </> "disks" </> "raw" </> "0.size"-          versFile = repo </> "machines" </> name </> "disks" </> "raw" </> "VERSION"-      exportAndRemoveImage buildImg destImg-      cmd-        (printf-           "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ \-           \{print $4}' | tr -d '(') > '%s'"-           destFile-           sizeFile)-      buildDate <- getBuildDate-      buildId <- getBuildId-      liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))-    Transient ->-      return ()+    case dest of+        (Share name imgType imgResize) -> do+            resizeImage imgResize buildImg+            let shareableImg = changeImageFormat imgType buildImg+            exportAndRemoveImage buildImg shareableImg+            void (shareImage shareableImg (SharedImageName name))+        (LocalFile destImg imgResize) -> do+            resizeImage imgResize buildImg+            exportAndRemoveImage buildImg destImg+        (LiveInstallerImage name repo imgResize) -> do+            resizeImage imgResize buildImg+            let destImg = Image destFile Raw buildImgFs+                (Image _ _ buildImgFs) = buildImg+                destFile =+                    repo </> "machines" </> name </> "disks" </> "raw" </>+                    "0.raw"+                sizeFile =+                    repo </> "machines" </> name </> "disks" </> "raw" </>+                    "0.size"+                versFile =+                    repo </> "machines" </> name </> "disks" </> "raw" </>+                    "VERSION"+            exportAndRemoveImage buildImg destImg+            cmd+                (printf+                     "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'"+                     destFile+                     sizeFile)+            buildDate <- getBuildDate+            buildId <- getBuildId+            liftIO (writeFile versFile (buildId ++ "-" ++ buildDate))+        Transient -> return ()  createEmptyImage :: String                  -> FileSystem@@ -218,33 +223,42 @@                  -> Image                  -> B9 () createEmptyImage fsLabel fsType imgType imgSize dest@(Image _ imgType' fsType')-  | fsType /= fsType' = error-                          (printf-                             "Conflicting createEmptyImage parameters. \-                             \Requested is file system %s but the destination \-                             \image has %s."-                             (show fsType)-                             (show fsType'))-  | imgType /= imgType' = error-                            (printf-                               "Conflicting createEmptyImage parameters. \-                               \Requested is image type %s but the destination \-                               \image has type %s."-                               (show imgType)-                               (show imgType'))+  | fsType /= fsType' =+      error+          (printf+               "Conflicting createEmptyImage parameters. Requested is file system %s but the destination image has %s."+               (show fsType)+               (show fsType'))+  | imgType /= imgType' =+      error+          (printf+               "Conflicting createEmptyImage parameters. Requested is image type %s but the destination image has type %s."+               (show imgType)+               (show imgType'))   | otherwise = do       let (Image imgFile imgFmt imgFs) = dest-      dbgL (printf "Creating empty raw image '%s' with size %s" imgFile (toQemuSizeOptVal imgSize))+      dbgL+          (printf+               "Creating empty raw image '%s' with size %s"+               imgFile+               (toQemuSizeOptVal imgSize))       cmd-        (printf "qemu-img create -f %s '%s' '%s'" (imageFileExtension imgFmt) imgFile-           (toQemuSizeOptVal imgSize))+          (printf+               "qemu-img create -f %s '%s' '%s'"+               (imageFileExtension imgFmt)+               imgFile+               (toQemuSizeOptVal imgSize))       case (imgFmt, imgFs) of-        (Raw, Ext4) -> do-          let fsCmd = "mkfs.ext4"-          dbgL (printf "Creating file system %s" (show imgFs))-          cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile)-        (it, fs) ->-          error (printf "Cannot create file system %s in image type %s" (show fs) (show it))+          (Raw,Ext4) -> do+              let fsCmd = "mkfs.ext4"+              dbgL (printf "Creating file system %s" (show imgFs))+              cmd (printf "%s -L '%s' -q '%s'" fsCmd fsLabel imgFile)+          (it,fs) ->+              error+                  (printf+                       "Cannot create file system %s in image type %s"+                       (show fs)+                       (show it))   createCOWImage :: Image -> Image -> B9 ()

@@ -3,8 +3,14 @@ module B9.DiskImages where  import           B9.QCUtil+import           GHC.Generics (Generic)+#if !MIN_VERSION_base(4,8,0) import           Control.Applicative+#endif+import           Control.Parallel.Strategies+import           Data.Binary import           Data.Data+import           Data.Hashable import           Data.Maybe import           Data.Semigroup import           System.FilePath@@ -22,12 +28,20 @@                      ImageDestination                      ImageSource                      MountPoint-                     deriving (Read, Show, Typeable, Data, Eq)+                     deriving (Read, Show, Typeable, Data, Eq,Generic) +instance Hashable ImageTarget+instance Binary ImageTarget+instance NFData ImageTarget+ -- | A mount point or 'NotMounted' data MountPoint = MountPoint FilePath | NotMounted-                     deriving (Show, Read, Typeable, Data, Eq)+                     deriving (Show, Read, Typeable, Data, Eq,Generic) +instance Hashable MountPoint+instance Binary MountPoint+instance NFData MountPoint+ -- | The destination of an image. data ImageDestination = Share String ImageType ImageResize                       -- ^ Create the image and some meta data so that other@@ -43,8 +57,12 @@                       -- objective of the b9 build is not an image file, but                       -- rather some artifact produced by executing by a                       -- containerize build.-                      deriving (Read, Show, Typeable, Data,Eq)+                      deriving (Read, Show, Typeable, Data,Eq,Generic) +instance Hashable ImageDestination+instance Binary ImageDestination+instance NFData ImageDestination+ -- | Specification of how the image to build is obtained. data ImageSource = EmptyImage String FileSystem ImageType ImageSize                   -- ^ Create an empty image file having a file system label@@ -59,38 +77,66 @@                   -- the partition table and extract it using @dd@.                  | From String ImageResize                   -- ^ Use an image previously shared by via 'Share'.-                 deriving (Show,Read,Typeable,Data,Eq)+                 deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable ImageSource+instance Binary ImageSource+instance NFData ImageSource+ -- | The partition to extract. data Partition = NoPT -- ^ There is no partition table on the image                | Partition Int -- ^ Extract partition @n@ @n@ must be in @0..3@-  deriving (Eq, Show, Read, Typeable, Data)+  deriving (Eq, Show, Read, Typeable, Data,Generic) +instance Hashable Partition+instance Binary Partition+instance NFData Partition+ -- | A vm disk image file consisting of a path to the image file, and the type -- and file system. data Image = Image FilePath ImageType FileSystem-           deriving (Eq, Show, Read, Typeable, Data)+           deriving (Eq, Show, Read, Typeable, Data,Generic) +instance Hashable Image+instance Binary Image+instance NFData Image+ -- | An image type defines the actual /file format/ of a file containing file -- systems. These are like /virtual harddrives/ data ImageType = Raw | QCow2 | Vmdk-               deriving (Eq,Read,Typeable,Data,Show)+               deriving (Eq,Read,Typeable,Data,Show,Generic) +instance Hashable ImageType+instance Binary ImageType+instance NFData ImageType+ -- | The file systems that b9 can use and convert. data FileSystem = NoFileSystem | Ext4 | ISO9660 | VFAT-                deriving (Eq,Show,Read,Typeable,Data)+                deriving (Eq,Show,Read,Typeable,Data,Generic) +instance Hashable FileSystem+instance Binary FileSystem+instance NFData FileSystem+ -- | A data type for image file or file system size; instead of passing 'Int's -- around this also captures a size unit so that the 'Int' can be kept small data ImageSize = ImageSize Int SizeUnit-                 deriving (Eq, Show, Read, Typeable, Data)+                 deriving (Eq, Show, Read, Typeable, Data, Generic) +instance Hashable ImageSize+instance Binary ImageSize+instance NFData ImageSize+ -- | Enumeration of size multipliers. The exact semantics may vary depending on -- what external tools look at these. E.g. the size unit is convert to a size -- parameter of the @qemu-img@ command line tool. data SizeUnit = B | KB | MB | GB-              deriving (Eq, Show, Read, Ord, Typeable, Data)+              deriving (Eq, Show, Read, Ord, Typeable, Data, Generic) +instance Hashable SizeUnit+instance Binary SizeUnit+instance NFData SizeUnit+ -- | How to resize an image file. data ImageResize = ResizeImage ImageSize                    -- ^ Resize the image __but not the file system__. Note that@@ -105,8 +151,12 @@                    -- smallest size to fit the contents of the file system.                  | KeepSize                    -- ^ Do not change the image size.-                   deriving (Eq, Show, Read, Typeable, Data)+                   deriving (Eq, Show, Read, Typeable, Data, Generic) +instance Hashable ImageResize+instance Binary ImageResize+instance NFData ImageResize+ -- | A type alias that indicates that something of type @a@ is mount at a -- 'MountPoint' type Mounted a = (a, MountPoint)@@ -122,18 +172,22 @@                 SharedImageBuildId                 ImageType                 FileSystem-    deriving (Eq,Read,Show)+    deriving (Eq,Read,Show,Typeable,Data,Generic) +instance Hashable SharedImage+instance Binary SharedImage+instance NFData SharedImage+ -- | The name of the image is the de-facto identifier for push, pull, 'From' and --   'Share'.  B9 always selects the newest version the shared image identified --   by that name when using a shared image as an 'ImageSource'. This is a --   wrapper around a string that identifies a 'SharedImage'-newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show)+newtype SharedImageName = SharedImageName String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)  -- | The exact time that build job __started__. --   This is a wrapper around a string contains the build date of a --   'SharedImage'; this is purely additional convenience and typesafety-newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show)+newtype SharedImageDate = SharedImageDate String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)  -- | Every B9 build running in a 'B9Monad' --   contains a random unique id that is generated once per build (no matter how@@ -141,7 +195,7 @@ --   of the build that created the shared image instance.  This is A wrapper --   around a string contains the build id of a 'SharedImage'; this is purely --   additional convenience and typesafety-newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show)+newtype SharedImageBuildId = SharedImageBuildId String deriving (Eq,Ord,Read,Show,Typeable,Data,Hashable,Binary,NFData)  -- | Shared images are orderd by name, build date and build id instance Ord SharedImage where

@@ -14,47 +14,80 @@     RamSize(..),     ) where +import Control.Parallel.Strategies+import Data.Binary import Data.Data+import Data.Hashable import Data.Monoid  import B9.DiskImages+import GHC.Generics (Generic) -data ExecEnv = ExecEnv { envName :: String-                       , envImageMounts :: [Mounted Image]-                       , envSharedDirectories :: [SharedDirectory]-                       , envResources :: Resources-                       }+data ExecEnv = ExecEnv+    { envName :: String+    , envImageMounts :: [Mounted Image]+    , envSharedDirectories :: [SharedDirectory]+    , envResources :: Resources+    }+    deriving (Read,Show,Typeable,Data,Eq,Generic) -data SharedDirectory = SharedDirectory FilePath MountPoint-                     | SharedDirectoryRO FilePath MountPoint-                     | SharedSources MountPoint-  deriving (Read, Show, Typeable, Data, Eq)+instance Hashable ExecEnv+instance Binary ExecEnv+instance NFData ExecEnv -data Resources = Resources { maxMemory :: RamSize-                           , cpuCount :: Int-                           , cpuArch :: CPUArch-                           }-  deriving (Read, Show, Typeable, Data)+data SharedDirectory+    = SharedDirectory FilePath+                      MountPoint+    | SharedDirectoryRO FilePath+                        MountPoint+    | SharedSources MountPoint+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable SharedDirectory+instance Binary SharedDirectory+instance NFData SharedDirectory++data Resources = Resources+    { maxMemory :: RamSize+    , cpuCount :: Int+    , cpuArch :: CPUArch+    } deriving (Eq,Read,Show,Typeable,Data,Generic)++instance Hashable Resources+instance Binary Resources+instance NFData Resources+ instance Monoid Resources where-  mempty = Resources mempty 1 mempty-  mappend (Resources m c a) (Resources m' c' a') = Resources (m <> m') (max c c') (a <> a')+    mempty = Resources mempty 1 mempty+    mappend (Resources m c a) (Resources m' c' a') =+        Resources (m <> m') (max c c') (a <> a')  noResources :: Resources noResources = mempty -data CPUArch = X86_64-             | I386-  deriving (Read, Show, Typeable, Data, Eq)+data CPUArch+    = X86_64+    | I386+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable CPUArch+instance Binary CPUArch+instance NFData CPUArch+ instance Monoid CPUArch where     mempty = I386     I386 `mappend` x = x     X86_64 `mappend` _ = X86_64 -data RamSize = RamSize Int SizeUnit-             | AutomaticRamSize-  deriving (Eq, Read, Show, Ord, Typeable, Data)+data RamSize+    = RamSize Int+              SizeUnit+    | AutomaticRamSize+    deriving (Eq,Read,Show,Ord,Typeable,Data,Generic)++instance Hashable RamSize+instance Binary RamSize+instance NFData RamSize  instance Monoid RamSize where     mempty = AutomaticRamSize

@@ -215,39 +215,11 @@              -> FilePath              -> String createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =-  "<domain type='lxc'>\n\-  \  <name>" ++ buildId ++ "</name>\n\-  \  <uuid>" ++ uuid ++ "</uuid>\n\-  \  <memory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</memory>\n\-  \  <currentMemory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</currentMemory>\n\-  \  <vcpu placement='static'>" ++ cpuCountStr e ++ "</vcpu>\n\-  \  <features>\n\-  \   <capabilities policy='default'>\n\-  \     "++ renderGuestCapabilityEntries cfg  ++"\n\-  \   </capabilities>\n\-  \  </features>\n\-  \  <os>\n\-  \    <type arch='" ++ osArch e ++ "'>exe</type>\n\-  \    <init>" ++ scriptDirGuest </> initScript ++ "</init>\n\-  \  </os>\n\-  \  <clock offset='utc'/>\n\-  \  <on_poweroff>destroy</on_poweroff>\n\-  \  <on_reboot>restart</on_reboot>\n\-  \  <on_crash>destroy</on_crash>\n\-  \  <devices>\n\-  \    <emulator>" ++ emulator cfg ++ "</emulator>\n"+  "<domain type='lxc'>\n  <name>" ++ buildId ++ "</name>\n  <uuid>" ++ uuid ++ "</uuid>\n  <memory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</memory>\n  <currentMemory unit='" ++ memoryUnit cfg e ++ "'>" ++ memoryAmount cfg e ++ "</currentMemory>\n  <vcpu placement='static'>" ++ cpuCountStr e ++ "</vcpu>\n  <features>\n   <capabilities policy='default'>\n     "++ renderGuestCapabilityEntries cfg  ++"\n   </capabilities>\n  </features>\n  <os>\n    <type arch='" ++ osArch e ++ "'>exe</type>\n    <init>" ++ scriptDirGuest </> initScript ++ "</init>\n  </os>\n  <clock offset='utc'/>\n  <on_poweroff>destroy</on_poweroff>\n  <on_reboot>restart</on_reboot>\n  <on_crash>destroy</on_crash>\n  <devices>\n    <emulator>" ++ emulator cfg ++ "</emulator>\n"   ++ unlines (libVirtNetwork (networkId cfg) ++               (fsImage <$> envImageMounts e) ++               (fsSharedDir <$> envSharedDirectories e)) ++ "\n" ++-  "    <filesystem type='mount'>\n\-  \      <source dir='" ++ scriptDirHost ++ "'/>\n\-  \      <target dir='" ++ scriptDirGuest ++ "'/>\n\-  \    </filesystem>\n\-  \    <console>\n\-  \      <target type='lxc' port='0'/>\n\-  \    </console>\n\-  \  </devices>\n\-  \</domain>\n"+  "    <filesystem type='mount'>\n      <source dir='" ++ scriptDirHost ++ "'/>\n      <target dir='" ++ scriptDirGuest ++ "'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\n"  renderGuestCapabilityEntries :: LibVirtLXCConfig -> String renderGuestCapabilityEntries = unlines . map render . guestCapabilities

@@ -5,7 +5,9 @@               , MBR(..)               , CHS(..)) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.Binary.Get import Data.Word import Text.Printf@@ -15,21 +17,23 @@ 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)+        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

@@ -2,7 +2,9 @@     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 )  import qualified B9.MBR as MBR

@@ -3,7 +3,9 @@ -} module B9.QCUtil where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Control.Monad import Test.QuickCheck 

@@ -21,7 +21,9 @@  import Control.Monad import Control.Monad.IO.Class+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.Data import Data.List import Data.ConfigFile

@@ -81,28 +81,22 @@  -- | Push a file from the cache to a remote repository pullGlob :: FilePath -> FilePathGlob -> RemoteRepo -> B9 ()-pullGlob subDir glob repo@(RemoteRepo repoId-                                      rootDir-                                      _key-                                      (SshRemoteHost (host, _port))-                                      (SshRemoteUser user)) = do-  cache <- getRepoCache-  infoL (printf "SYNCING REPO METADATA '%s'" repoId)-  let c = printf "rsync -rtv\-                 \ --include '%s'\-                 \ --exclude '*.*'\-                 \ -e 'ssh %s'\-                 \ '%s@%s:%s/' '%s/'"-                 (globToPattern glob)-                 (sshOpts repo)-                 user-                 host-                 (rootDir </> subDir)-                 destDir-      destDir = repoCacheDir </> subDir-      repoCacheDir = remoteRepoCacheDir cache repoId-  ensureDir destDir-  cmd c+pullGlob subDir glob repo@(RemoteRepo repoId rootDir _key (SshRemoteHost (host,_port)) (SshRemoteUser user)) = do+    cache <- getRepoCache+    infoL (printf "SYNCING REPO METADATA '%s'" repoId)+    let c =+            printf+                "rsync -rtv --include '%s' --exclude '*.*' -e 'ssh %s' '%s@%s:%s/' '%s/'"+                (globToPattern glob)+                (sshOpts repo)+                user+                host+                (rootDir </> subDir)+                destDir+        destDir = repoCacheDir </> subDir+        repoCacheDir = remoteRepoCacheDir cache repoId+    ensureDir destDir+    cmd c  -- | Express a pattern for file paths, used when searching repositories. data FilePathGlob = FileExtension String

@@ -10,58 +10,107 @@                       ) where  import Data.Data+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative import Data.Monoid+#endif+import Control.Parallel.Strategies+import Data.Binary+import Data.Hashable+import GHC.Generics (Generic) import Control.Monad.Reader-import Control.Applicative ( (<$>) ) import Data.List ( intercalate ) import System.Directory ( getPermissions                         , setPermissions                         , setOwnerExecutable ) -data Script = In FilePath [Script]-            | As String [Script]-            | IgnoreErrors Bool [Script]-            | Verbosity CmdVerbosity [Script]-            | Begin [Script]-            | Run FilePath [String]-            | NoOP-            deriving (Show, Read, Typeable, Data,Eq)+data Script+    = In FilePath+         [Script]+    | As String+         [Script]+    | IgnoreErrors Bool+                   [Script]+    | Verbosity CmdVerbosity+                [Script]+    | Begin [Script]+    | Run FilePath+          [String]+    | NoOP+    deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable Script+instance Binary Script+instance NFData Script+ instance Monoid Script where-  mempty = NoOP-  NoOP `mappend` s = s-  s `mappend` NoOP = s-  (Begin ss) `mappend` (Begin ss') = Begin (ss ++ ss')-  (Begin ss) `mappend` s' = Begin (ss ++ [s'])-  s `mappend` (Begin ss') = Begin (s : ss')-  s `mappend` s' = Begin [s, s']+    mempty = NoOP+    NoOP `mappend` s = s+    s `mappend` NoOP = s+    (Begin ss) `mappend` (Begin ss') = Begin (ss ++ ss')+    (Begin ss) `mappend` s' = Begin (ss ++ [s'])+    s `mappend` (Begin ss') = Begin (s : ss')+    s `mappend` s' = Begin [s, s'] -data Cmd = Cmd String-               [String]-               User-               Cwd-               Bool-               CmdVerbosity-               deriving (Show, Read)+data Cmd =+    Cmd String+        [String]+        User+        Cwd+        Bool+        CmdVerbosity+    deriving (Show,Read,Typeable,Data,Eq,Generic) -data CmdVerbosity = Debug | Verbose | OnlyStdErr | Quiet-                  deriving (Show, Read, Typeable, Data,Eq)+instance Hashable Cmd+instance Binary Cmd+instance NFData Cmd -data Cwd = Cwd FilePath | NoCwd deriving (Show, Read)+data CmdVerbosity+    = Debug+    | Verbose+    | OnlyStdErr+    | Quiet+    deriving (Show,Read,Typeable,Data,Eq,Generic) -data User = User String | NoUser deriving (Show, Read)+instance Hashable CmdVerbosity+instance Binary CmdVerbosity+instance NFData CmdVerbosity -data Ctx = Ctx { ctxCwd :: Cwd-               , ctxUser :: User-               , ctxIgnoreErrors :: Bool-               , ctxVerbosity :: CmdVerbosity }+data Cwd+    = Cwd FilePath+    | NoCwd+    deriving (Show,Read,Typeable,Data,Eq,Generic) +instance Hashable Cwd+instance Binary Cwd+instance NFData Cwd++data User+    = User String+    | NoUser+    deriving (Show,Read,Typeable,Data,Eq,Generic)++instance Hashable User+instance Binary User+instance NFData User++data Ctx = Ctx+    { ctxCwd :: Cwd+    , ctxUser :: User+    , ctxIgnoreErrors :: Bool+    , ctxVerbosity :: CmdVerbosity+    } deriving (Show,Read,Typeable,Data,Eq,Generic)++instance Hashable Ctx+instance Binary Ctx+instance NFData Ctx+ -- | Convert 'script' to bash-shell-script written to 'file' and make 'file' -- executable. writeSh :: FilePath -> Script -> IO () writeSh file script = do-  writeFile file (toBash $ toCmds script)-  getPermissions file >>= setPermissions file . setOwnerExecutable True+    writeFile file (toBash $ toCmds script)+    getPermissions file >>= setPermissions file . setOwnerExecutable True  -- | Check if a script has the same effect as 'NoOP' emptyScript :: Script -> Bool@@ -72,55 +121,75 @@   where     toLLC :: Script -> Reader Ctx [Cmd]     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))-    toLLC (IgnoreErrors b cs) = local (\ ctx -> ctx { ctxIgnoreErrors = b })-                                (toLLC (Begin cs))-    toLLC (Verbosity v cs) = local (\ ctx -> ctx { ctxVerbosity = v})-                             (toLLC (Begin cs))+    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))+    toLLC (IgnoreErrors b 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     toLLC (Run cmd args) = do-      c <- reader ctxCwd-      u <- reader ctxUser-      i <- reader ctxIgnoreErrors-      v <- reader ctxVerbosity-      return [Cmd cmd args u c i v]+        c <- reader ctxCwd+        u <- reader ctxUser+        i <- reader ctxIgnoreErrors+        v <- reader ctxVerbosity+        return [Cmd cmd args u c i v]  toBash :: [Cmd] -> String-toBash cmds =-  intercalate "\n\n" $-  bashHeader ++ (cmdToBash <$> cmds)+toBash cmds = intercalate "\n\n" $ bashHeader ++ (cmdToBash <$> cmds)  bashHeader :: [String]-bashHeader = [ "#!/bin/bash"-             , "set -e" ]+bashHeader = ["#!/bin/bash", "set -e"]  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 = [ ]-    pushd (Cwd cwdPath) = [ unwords (["pushd", cwdPath] ++ redirectOutput) ]-    popd NoCwd = [ ]-    popd (Cwd cwdPath) = [ unwords (["popd"] ++ redirectOutput ++ ["#", cwdPath]) ]+    execCmd = [unwords (runuser ++ [cmd] ++ args ++ redirectOutput)]+      where+        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"]+    cwdQ =+        case cwd of+            NoCwd -> NoCwd+            Cwd d -> Cwd ("'" ++ d ++ "'")+    redirectOutput =+        case verbosity of+            Debug -> []+            Verbose -> []+            OnlyStdErr -> [">", "/dev/null"]+            Quiet -> ["&>", "/dev/null"]

@@ -5,9 +5,13 @@ module B9.Vm (VmScript (..)              ,substVmScript) where +import Control.Parallel.Strategies+import Data.Binary import Data.Data+import Data.Generics.Aliases hiding (Generic) import Data.Generics.Schemes-import Data.Generics.Aliases+import Data.Hashable+import GHC.Generics (Generic)  import B9.ShellScript import B9.DiskImages@@ -16,30 +20,31 @@  -- | Describe a virtual machine, i.e. a set up disk images to create and a shell -- script to put things together.-data VmScript = VmScript CPUArch [SharedDirectory] Script-              | NoVmScript-  deriving (Read, Show, Typeable, Data, Eq)+data VmScript+    = VmScript CPUArch+               [SharedDirectory]+               Script+    | NoVmScript+    deriving (Read,Show,Typeable,Data,Eq,Generic) +instance Hashable VmScript+instance Binary VmScript+instance NFData VmScript+ substVmScript :: [(String,String)] -> VmScript -> VmScript substVmScript env = everywhere gsubst   where-    gsubst :: Data a => a -> a-    gsubst = mkT substMountPoint-             `extT` substSharedDir-             `extT` substScript-+    gsubst+        :: Data a+        => a -> a+    gsubst = mkT substMountPoint `extT` substSharedDir `extT` substScript     substMountPoint NotMounted = NotMounted     substMountPoint (MountPoint x) = MountPoint (sub x)--    substSharedDir (SharedDirectory fp mp) =-      SharedDirectory (sub fp) mp-    substSharedDir (SharedDirectoryRO fp mp) =-      SharedDirectoryRO (sub fp) mp+    substSharedDir (SharedDirectory fp mp) = SharedDirectory (sub fp) mp+    substSharedDir (SharedDirectoryRO fp mp) = SharedDirectoryRO (sub fp) mp     substSharedDir s = s-     substScript (In fp s) = In (sub fp) s     substScript (Run fp args) = Run (sub fp) (map sub args)     substScript (As fp s) = As (sub fp) s     substScript s = s-     sub = subst env

@@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module B9.Content.ErlangPropListSpec (spec) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.List import Test.Hspec import Test.QuickCheck@@ -61,9 +63,7 @@                                      ,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]

@@ -20,8 +20,7 @@                                           ,toJSON (123::Int)])        in (v1 <> v2) `shouldBe` combined -    it "combines objects with disjunct keys to an object \-       \containing all properties" $+    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@@ -35,9 +34,7 @@                                         ,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" $+    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@@ -49,31 +46,10 @@                                               ,Number 4]])        in (o1 <> o2) `shouldBe` combined -    it "combines 'write_files' and 'runcmd' from typical 'user-data' files \-       \by merging each" $-     let (Right ud1) = decodeSyntax "" "#user-data\n\-                                  \\n\-                                  \write_files:\n\-                                  \  - contents: |\n\-                                  \      hello world!\n\-                                  \\n\-                                  \    path: /sdf/xyz/filename.cfg\n\-                                  \    owner: root:root\n\-                                  \\n\-                                  \runcmd:\n\-                                  \ - x y z\n"+    it "combines 'write_files' and 'runcmd' from typical 'user-data' files by merging each" $+     let (Right ud1) = decodeSyntax "" "#user-data\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) = decodeSyntax "" "#user-data\n\-                                  \\n\-                                  \write_files:\n\-                                  \  - contents: |\n\-                                  \      hello world2!\n\-                                  \\n\-                                  \    path: /sdf/xyz/filename.cfg\n\-                                  \    owner: root:root\n\-                                  \\n\-                                  \runcmd:\n\-                                  \ - a b c\n"+         (Right ud2) = decodeSyntax "" "#user-data\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 = YamlObject                 (object

@@ -20,8 +20,7 @@                      itImageDestination                          (snd (splitToIntermediateSharedImage target name)))        it-           "puts the intermediate shared image name into both the \-            \intermediate and the export target" $+           "puts the intermediate shared image name into both the intermediate and the export target" $            property                (\target name ->                      let (intermediateTarget,exportTarget) =