summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Bootstrap.hs15
-rw-r--r--src/Propellor/Property/Chroot.hs18
-rw-r--r--src/Propellor/Property/DiskImage.hs8
-rw-r--r--src/Propellor/Property/Docker.hs10
4 files changed, 26 insertions, 25 deletions
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
index 5678a865..767d6ef7 100644
--- a/src/Propellor/Property/Bootstrap.hs
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -17,17 +17,17 @@ data RepoSource
-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
--- Normally, propellor is already bootstrapped when it runs, so this
--- property is not useful. However, this can be useful inside a
--- chroot used to build a disk image, to make the disk image
--- have propellor installed.
+-- This property only does anything when used inside a chroot.
+-- This is particularly useful inside a chroot used to build a
+-- disk image, to make the disk image have propellor installed.
--
-- The git repository is cloned (or pulled to update if it already exists).
--
-- All build dependencies are installed, using distribution packages
-- or falling back to using cabal.
bootstrappedFrom :: RepoSource -> Property Linux
-bootstrappedFrom reposource = go `requires` clonedFrom reposource
+bootstrappedFrom reposource = check inChroot $
+ go `requires` clonedFrom reposource
where
go :: Property Linux
go = property "Propellor bootstrapped" $ do
@@ -35,7 +35,8 @@ bootstrappedFrom reposource = go `requires` clonedFrom reposource
assumeChange $ exposeTrueLocaldir $ const $
runShellCommand $ buildShellCommand
[ "cd " ++ localdir
- , bootstrapPropellorCommand system
+ , checkDepsCommand system
+ , buildCommand
]
-- | Clones the propellor repeository into /usr/local/propellor/
@@ -83,7 +84,7 @@ clonedFrom reposource = case reposource of
-- configuration.
copygitconfig :: Property Linux
copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
- let gitconfig = localdir <> ".git" <> "config"
+ let gitconfig = localdir </> ".git" </> "config"
cfg <- liftIO $ B.readFile gitconfig
exposeTrueLocaldir $ const $
liftIO $ B.writeFile gitconfig cfg
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ad2ae705..65749e34 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -37,7 +37,6 @@ import Utility.Split
import qualified Data.Map as M
import System.Posix.Directory
-import System.Console.Concurrent
-- | Specification of a chroot. Normally you'll use `debootstrapped` or
-- `bootstrapped` to construct a Chroot value.
@@ -201,9 +200,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
, "--continue"
, show cmd
]
- let p' = p { env = Just pe }
- r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
- processChainOutput
+ r <- liftIO $ chainPropellor (p { env = Just pe })
liftIO cleanup
return r
@@ -223,13 +220,12 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
go h = do
changeWorkingDirectory localdir
when onconsole forceConsole
- onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureChildProperties $
- if systemdonly
- then [toChildProperty Systemd.installed]
- else hostProperties h
- flushConcurrentOutput
- putStrLn $ "\n" ++ show r
+ onlyProcess (provisioningLock loc) $
+ runChainPropellor (setInChroot h) $
+ ensureChildProperties $
+ if systemdonly
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
chain _ _ = errorMessage "bad chain command"
inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 90b7010b..d5898d7c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -247,7 +247,7 @@ getMountSz szm l (Just mntpt) =
--
-- If the file is too large, truncates it down to the specified size.
imageExists :: FilePath -> ByteSize -> Property Linux
-imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
+imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
@@ -258,6 +258,12 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
_ -> do
L.writeFile img (L.replicate (fromIntegral sz) 0)
return MadeChange
+ where
+ sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize
+ -- Disks have a sector size, and making a disk image not
+ -- aligned to a sector size will confuse some programs.
+ -- Common sector sizes are 512 and 4096; use 4096 as it's larger.
+ sectorsize = 4096 :: Double
-- | A pair of properties. The first property is satisfied within the
-- chroot, and is typically used to download the boot loader.
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index d53bab71..66418253 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -576,8 +576,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
let p = inContainerProcess cid
(if isConsole msgh then ["-it"] else [])
(shim : params)
- r <- withHandle StdoutHandle createProcessSuccess p $
- processChainOutput
+ r <- chainPropellor p
when (r /= FailedChange) $
setProvisionedFlag cid
return r
@@ -596,10 +595,9 @@ chain hostlist hn s = case toContainerId s of
where
go cid h = do
changeWorkingDirectory localdir
- onlyProcess (provisioningLock cid) $ do
- r <- runPropellor h $ ensureChildProperties $ hostProperties h
- flushConcurrentOutput
- putStrLn $ "\n" ++ show r
+ onlyProcess (provisioningLock cid) $
+ runChainPropellor h $
+ ensureChildProperties $ hostProperties h
stopContainer :: ContainerId -> IO Bool
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]