summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-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
6 files changed, 45 insertions, 20 deletions
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 =