Merge branch 'joeyconfig'

This commit is contained in:
Joey Hess 2015-05-30 11:05:56 -04:00
commit b36a75fd93
9 changed files with 127 additions and 66 deletions

View File

@ -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"

10
debian/changelog vendored
View File

@ -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

View File

@ -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

View File

@ -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.
--

View File

@ -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

View File

@ -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]

View File

@ -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
@ -41,7 +42,7 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup
, ("postfix/destinations", "string", "localhost")
, ("postfix/mailname", "string", hn)
]
, mainCf ("relayhost", domain)
, mainCf ("relayhost", "smtp." ++ domain)
`onChange` reloaded
]

View File

@ -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
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
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 (Cron.Times $ show buildminute ++ " * * * *") timeout
where
name = arch ++ "-git-annex-builder"
bootstrap = Chroot.debootstrapped osver mempty
osver = System (Debian Testing) arch
& autobuilder arch crontime timeout
androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
androidAutoBuilderContainer crontimes timeout =

View File

@ -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