summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-05-30 11:05:56 -0400
committerJoey Hess2015-05-30 11:05:56 -0400
commitb36a75fd93a730ea148e67eb7bf1300d738ff82a (patch)
tree8f65595e6de56aabd39d7a6d125c16a99493fa19
parentfafe1e6f5ce082f93d0b97dbacdcb149778ccaf9 (diff)
parentaa7dcad9ba8d14013f26f6e8554901d56ef4cb5c (diff)
Merge branch 'joeyconfig'
-rw-r--r--config-joey.hs38
-rw-r--r--debian/changelog10
-rw-r--r--src/Propellor/Property/Chroot.hs13
-rw-r--r--src/Propellor/Property/Cmd.hs5
-rw-r--r--src/Propellor/Property/Debootstrap.hs4
-rw-r--r--src/Propellor/Property/Mount.hs11
-rw-r--r--src/Propellor/Property/Postfix.hs7
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs25
-rw-r--r--src/Utility/Process.hs80
9 files changed, 127 insertions, 66 deletions
diff --git a/config-joey.hs b/config-joey.hs
index 50e712a0..73c9687b 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -25,6 +25,7 @@ import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Systemd as Systemd
import qualified Propellor.Property.Journald as Journald
+import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.OS as OS
import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost
import qualified Propellor.Property.HostingProvider.Linode as Linode
@@ -45,6 +46,7 @@ hosts = -- (o) `
, gnu
, clam
, orca
+ , honeybee
, kite
, elephant
, beaver
@@ -128,10 +130,39 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
& Apt.unattendedUpgrades
& Postfix.satellite
+ & Apt.serviceInstalledRunning "ntp"
& Systemd.persistentJournal
- & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer "amd64" 15 "2h")
- & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer "i386" 15 "2h")
- & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer (Cron.Times "1 1 * * *") "3h")
+
+ & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer
+ (System (Debian Testing) "amd64") fifteenpast "2h")
+ & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer
+ (System (Debian Testing) "i386") fifteenpast "2h")
+ & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer
+ (Cron.Times "1 1 * * *") "3h")
+ where
+ fifteenpast = Cron.Times "15 * * * *"
+
+honeybee :: Host
+honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
+ [ "Arm git-annex build box." ]
+ & ipv6 "2001:4830:1600:187::2"
+
+ -- No unattended upgrades as there is currently no console access.
+ -- (Also, system is not currently running a stock kernel,
+ -- although it should be able to.)
+ & Postfix.satellite
+ & Apt.serviceInstalledRunning "ntp"
+ & Apt.serviceInstalledRunning "aiccu"
+
+ -- Not using systemd-nspawn because it's broken (kernel issue?)
+ -- & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer
+ -- osver Cron.Daily "22h")
+ & Chroot.provisioned
+ (Chroot.debootstrapped builderos mempty "/var/lib/container/armel-git-annex-builder"
+ & GitAnnexBuilder.standardAutoBuilder builderos Cron.Daily "22h")
+ where
+ -- Using unstable to get new enough ghc for TH on arm.
+ builderos = System (Debian Unstable) "armel"
-- This is not a complete description of kite, since it's a
-- multiuser system with eg, user passwords that are not deployed
@@ -310,6 +341,7 @@ beaver = host "beaver.kitenet.net"
-- Branchable is not completely deployed with propellor yet.
pell :: Host
pell = host "pell.branchable.com"
+ & alias "branchable.com"
& ipv4 "66.228.46.55"
& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
diff --git a/debian/changelog b/debian/changelog
index 5d70582e..9fae861c 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -4,11 +4,15 @@ propellor (2.5.0) UNRELEASED; urgency=medium
more generic cmdProperty' (API change)
* Add docker image related properties.
Thanks, Antoine Eiche.
- * Export CommandParam, boolSystem, safeSystem and shellEscape from
- Propellor.Property.Cmd, so they are available for use in constricting
- your own Properties when using propellor as a library.
+ * Export CommandParam, boolSystem, safeSystem, shellEscape, and
+ * createProcess from Propellor.Property.Cmd, so they are available
+ for use in constricting your own Properties when using propellor
+ as a library.
* Improve enter-machine scripts for nspawn containers to unset most
environment variables.
+ * Fix Postfix.satellite bug; the default relayhost was set to the
+ domain, not to smtp.domain as documented.
+ * Mount /proc inside a chroot before provisioning it, to work around #787227
-- Joey Hess <id@joeyh.name> Thu, 07 May 2015 12:08:34 -0400
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ec2b6679..0e9d00d8 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -16,6 +16,7 @@ import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Property.Chroot.Util
+import Propellor.Property.Mount
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Shim as Shim
@@ -55,8 +56,9 @@ debootstrapped system conf location = case system of
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
--- Reverting this property removes the chroot. Note that it does not ensure
--- that any processes that might be running inside the chroot are stopped.
+-- Reverting this property removes the chroot. Anything mounted inside it
+-- is first unmounted. Note that it does not ensure that any processes
+-- that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False
@@ -101,6 +103,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
( pure (Shim.file me d)
, Shim.setup me Nothing d
)
+ liftIO mountproc
ifM (liftIO $ bindmount shim)
( chainprovision shim
, return FailedChange
@@ -117,6 +120,12 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
]
)
+ -- /proc needs to be mounted in the chroot for the linker to use
+ -- /proc/self/exe which is necessary for some commands to work
+ mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
+ void $ mount "proc" "proc" procloc
+ procloc = loc </> "proc"
+
chainprovision shim = do
parenthost <- asks hostName
cmd <- liftIO $ toChain parenthost c systemdonly
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 23f1075b..23816a94 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -14,18 +14,19 @@ module Propellor.Property.Cmd (
boolSystemEnv,
safeSystem,
safeSystemEnv,
- shellEscape
+ shellEscape,
+ createProcess,
) where
import Control.Applicative
import Data.List
import "mtl" Control.Monad.Reader
-import System.Process (CreateProcess)
import Propellor.Types
import Propellor.Property
import Utility.SafeCommand
import Utility.Env
+import Utility.Process (createProcess, CreateProcess)
-- | A property that can be satisfied by running a command.
--
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index f29ae56b..8d974eba 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -106,9 +106,7 @@ unpopulated d = null <$> catchDefaultIO [] (dirContents d)
removetarget :: FilePath -> IO ()
removetarget target = do
- submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
- . filter (dirContains target)
- <$> mountPoints
+ submnts <- mountPointsBelow target
forM_ submnts umountLazy
removeDirectoryRecursive target
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index a081b1e7..ff47f4d9 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -1,22 +1,33 @@
module Propellor.Property.Mount where
import Propellor
+import Utility.Path
type FsType = String
type Source = String
+-- | Lists all mount points of the system.
mountPoints :: IO [FilePath]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
+-- | Finds all filesystems mounted inside the specified directory.
+mountPointsBelow :: FilePath -> IO [FilePath]
+mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
+ . filter (dirContains target)
+ <$> mountPoints
+
+-- | Filesystem type mounted at a given location.
getFsType :: FilePath -> IO (Maybe FsType)
getFsType mnt = catchDefaultIO Nothing $
headMaybe . lines
<$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"]
+-- | Unmounts a device, lazily so any running processes don't block it.
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
errorMessage $ "failed unmounting " ++ mnt
+-- | Mounts a device.
mount :: FsType -> Source -> FilePath -> IO Bool
mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 073d5dc8..b51f4df1 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -22,7 +22,8 @@ reloaded :: Property NoInfo
reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which
--- relays all mail through a relay host, which defaults to smtp.domain.
+-- relays all mail through a relay host, which defaults to smtp.domain,
+-- but can be changed by mainCf "relayhost"
--
-- The smarthost may refuse to relay mail on to other domains, without
-- futher coniguration/keys. But this should be enough to get cron job
@@ -34,14 +35,14 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
setup = trivial $ property "postfix satellite system" $ do
hn <- asks hostName
let (_, domain) = separate (== '.') hn
- ensureProperties
+ ensureProperties
[ Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
, ("postfix/root_address", "string", "root")
, ("postfix/destinations", "string", "localhost")
, ("postfix/mailname", "string", hn)
]
- , mainCf ("relayhost", domain)
+ , mainCf ("relayhost", "smtp." ++ domain)
`onChange` reloaded
]
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 86bf104c..3c638721 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -94,19 +94,24 @@ cabalDeps = flagFile go cabalupdated
go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"]
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
-standardAutoBuilderContainer :: Architecture -> Int -> TimeOut -> Systemd.Container
-standardAutoBuilderContainer arch buildminute timeout = Systemd.container name bootstrap
- & os osver
- & Apt.stdSourcesList
- & Apt.unattendedUpgrades
- & User.accountFor (User builduser)
- & tree arch
- & buildDepsApt
- & autobuilder arch (Cron.Times $ show buildminute ++ " * * * *") timeout
+standardAutoBuilderContainer :: System -> Times -> TimeOut -> Systemd.Container
+standardAutoBuilderContainer osver@(System _ arch) crontime timeout =
+ Systemd.container name bootstrap
+ & standardAutoBuilder osver crontime timeout
where
name = arch ++ "-git-annex-builder"
bootstrap = Chroot.debootstrapped osver mempty
- osver = System (Debian Testing) arch
+
+standardAutoBuilder :: System -> Times -> TimeOut -> Property HasInfo
+standardAutoBuilder osver@(System _ arch) crontime timeout =
+ propertyList "git-annex-builder" $ props
+ & os osver
+ & Apt.stdSourcesList
+ & Apt.unattendedUpgrades
+ & User.accountFor (User builduser)
+ & tree arch
+ & buildDepsApt
+ & autobuilder arch crontime timeout
androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
androidAutoBuilderContainer crontimes timeout =
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 9f98596b..469f7659 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -1,7 +1,7 @@
{- System.Process enhancements, including additional ways of running
- processes, and logging.
-
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -65,8 +65,8 @@ type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Hand
data StdHandle = StdinHandle | StdoutHandle | StderrHandle
deriving (Eq)
-{- Normally, when reading from a process, it does not need to be fed any
- - standard input. -}
+-- | Normally, when reading from a process, it does not need to be fed any
+-- standard input.
readProcess :: FilePath -> [String] -> IO String
readProcess cmd args = readProcessEnv cmd args Nothing
@@ -84,9 +84,8 @@ readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do
hClose h
return output
-{- Runs an action to write to a process on its stdin,
- - returns its output, and also allows specifying the environment.
- -}
+-- | Runs an action to write to a process on its stdin,
+-- returns its output, and also allows specifying the environment.
writeReadProcessEnv
:: FilePath
-> [String]
@@ -126,8 +125,8 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
, env = environ
}
-{- Waits for a ProcessHandle, and throws an IOError if the process
- - did not exit successfully. -}
+-- | Waits for a ProcessHandle, and throws an IOError if the process
+-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
forceSuccessProcess p pid = do
code <- waitForProcess pid
@@ -135,10 +134,10 @@ forceSuccessProcess p pid = do
ExitSuccess -> return ()
ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
-{- Waits for a ProcessHandle and returns True if it exited successfully.
- - Note that using this with createProcessChecked will throw away
- - the Bool, and is only useful to ignore the exit code of a process,
- - while still waiting for it. -}
+-- | Waits for a ProcessHandle and returns True if it exited successfully.
+-- Note that using this with createProcessChecked will throw away
+-- the Bool, and is only useful to ignore the exit code of a process,
+-- while still waiting for it. -}
checkSuccessProcess :: ProcessHandle -> IO Bool
checkSuccessProcess pid = do
code <- waitForProcess pid
@@ -149,13 +148,13 @@ ignoreFailureProcess pid = do
void $ waitForProcess pid
return True
-{- Runs createProcess, then an action on its handles, and then
- - forceSuccessProcess. -}
+-- | Runs createProcess, then an action on its handles, and then
+-- forceSuccessProcess.
createProcessSuccess :: CreateProcessRunner
createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
-{- Runs createProcess, then an action on its handles, and then
- - a checker action on its exit code, which must wait for the process. -}
+-- | Runs createProcess, then an action on its handles, and then
+-- a checker action on its exit code, which must wait for the process.
createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
createProcessChecked checker p a = do
t@(_, _, _, pid) <- createProcess p
@@ -163,14 +162,14 @@ createProcessChecked checker p a = do
_ <- checker pid
either E.throw return r
-{- Leaves the process running, suitable for lazy streaming.
- - Note: Zombies will result, and must be waited on. -}
+-- | Leaves the process running, suitable for lazy streaming.
+-- Note: Zombies will result, and must be waited on.
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
-{- Runs a process, optionally feeding it some input, and
- - returns a transcript combining its stdout and stderr, and
- - whether it succeeded or failed. -}
+-- | Runs a process, optionally feeding it some input, and
+-- returns a transcript combining its stdout and stderr, and
+-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts input = processTranscript' cmd opts Nothing input
@@ -234,9 +233,9 @@ processTranscript' cmd opts environ input = do
hClose inh
writeinput Nothing _ = return ()
-{- Runs a CreateProcessRunner, on a CreateProcess structure, that
- - is adjusted to pipe only from/to a single StdHandle, and passes
- - the resulting Handle to an action. -}
+-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
+-- is adjusted to pipe only from/to a single StdHandle, and passes
+-- the resulting Handle to an action.
withHandle
:: StdHandle
-> CreateProcessRunner
@@ -258,7 +257,7 @@ withHandle h creator p a = creator p' $ a . select
| h == StderrHandle =
(stderrHandle, base { std_err = CreatePipe })
-{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles
:: CreateProcessRunner
-> CreateProcess
@@ -272,7 +271,7 @@ withIOHandles creator p a = creator p' $ a . ioHandles
, std_err = Inherit
}
-{- Like withHandle, but passes (stdout, stderr) handles to the action. -}
+-- | Like withHandle, but passes (stdout, stderr) handles to the action.
withOEHandles
:: CreateProcessRunner
-> CreateProcess
@@ -286,8 +285,8 @@ withOEHandles creator p a = creator p' $ a . oeHandles
, std_err = CreatePipe
}
-{- Forces the CreateProcessRunner to run quietly;
- - both stdout and stderr are discarded. -}
+-- | Forces the CreateProcessRunner to run quietly;
+-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
@@ -299,8 +298,8 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
}
creator p' $ const $ return ()
-{- Stdout and stderr are discarded, while the process is fed stdin
- - from the handle. -}
+-- | Stdout and stderr are discarded, while the process is fed stdin
+-- from the handle.
feedWithQuietOutput
:: CreateProcessRunner
-> CreateProcess
@@ -321,11 +320,11 @@ devNull = "/dev/null"
devNull = "NUL"
#endif
-{- Extract a desired handle from createProcess's tuple.
- - These partial functions are safe as long as createProcess is run
- - with appropriate parameters to set up the desired handle.
- - Get it wrong and the runtime crash will always happen, so should be
- - easily noticed. -}
+-- | Extract a desired handle from createProcess's tuple.
+-- These partial functions are safe as long as createProcess is run
+-- with appropriate parameters to set up the desired handle.
+-- Get it wrong and the runtime crash will always happen, so should be
+-- easily noticed.
type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
stdinHandle :: HandleExtractor
stdinHandle (Just h, _, _, _) = h
@@ -346,7 +345,7 @@ oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
-{- Debugging trace for a CreateProcess. -}
+-- | Debugging trace for a CreateProcess.
debugProcess :: CreateProcess -> IO ()
debugProcess p = do
debugM "Utility.Process" $ unwords
@@ -362,15 +361,15 @@ debugProcess p = do
piped Inherit = False
piped _ = True
-{- Shows the command that a CreateProcess will run. -}
+-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
where
go (ShellCommand s) = s
go (RawCommand c ps) = c ++ " " ++ show ps
-{- Starts an interactive process. Unlike runInteractiveProcess in
- - System.Process, stderr is inherited. -}
+-- | Starts an interactive process. Unlike runInteractiveProcess in
+-- System.Process, stderr is inherited.
startInteractiveProcess
:: FilePath
-> [String]
@@ -386,7 +385,8 @@ startInteractiveProcess cmd args environ = do
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
-{- Wrapper around System.Process function that does debug logging. -}
+-- | Wrapper around 'System.Process.createProcess' from System.Process,
+-- that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p