summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Bootstrap.hs203
-rw-r--r--src/Propellor/CmdLine.hs53
-rw-r--r--src/Propellor/Container.hs21
-rw-r--r--src/Propellor/DotDir.hs6
-rw-r--r--src/Propellor/Engine.hs61
-rw-r--r--src/Propellor/EnsureProperty.hs4
-rw-r--r--src/Propellor/Gpg.hs34
-rw-r--r--src/Propellor/Info.hs9
-rw-r--r--src/Propellor/Message.hs58
-rw-r--r--src/Propellor/PrivData.hs10
-rw-r--r--src/Propellor/Property.hs60
-rw-r--r--src/Propellor/Property/Apache.hs36
-rw-r--r--src/Propellor/Property/Apt.hs193
-rw-r--r--src/Propellor/Property/Apt/PPA.hs30
-rw-r--r--src/Propellor/Property/Attic.hs18
-rw-r--r--src/Propellor/Property/Bootstrap.hs144
-rw-r--r--src/Propellor/Property/Borg.hs16
-rw-r--r--src/Propellor/Property/Ccache.hs2
-rw-r--r--src/Propellor/Property/Chroot.hs122
-rw-r--r--src/Propellor/Property/Cmd.hs1
-rw-r--r--src/Propellor/Property/Concurrent.hs11
-rw-r--r--src/Propellor/Property/Conductor.hs6
-rw-r--r--src/Propellor/Property/ConfFile.hs25
-rw-r--r--src/Propellor/Property/Cron.hs5
-rw-r--r--src/Propellor/Property/DebianMirror.hs2
-rw-r--r--src/Propellor/Property/Debootstrap.hs3
-rw-r--r--src/Propellor/Property/DiskImage.hs290
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs80
-rw-r--r--src/Propellor/Property/Dns.hs14
-rw-r--r--src/Propellor/Property/Docker.hs28
-rw-r--r--src/Propellor/Property/File.hs119
-rw-r--r--src/Propellor/Property/Firejail.hs2
-rw-r--r--src/Propellor/Property/Firewall.hs77
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs5
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs14
-rw-r--r--src/Propellor/Property/FreeDesktop.hs29
-rw-r--r--src/Propellor/Property/Fstab.hs29
-rw-r--r--src/Propellor/Property/Gpg.hs2
-rw-r--r--src/Propellor/Property/Grub.hs72
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs5
-rw-r--r--src/Propellor/Property/Hostname.hs2
-rw-r--r--src/Propellor/Property/LightDM.hs13
-rw-r--r--src/Propellor/Property/List.hs9
-rw-r--r--src/Propellor/Property/Locale.hs6
-rw-r--r--src/Propellor/Property/Logcheck.hs12
-rw-r--r--src/Propellor/Property/Mount.hs23
-rw-r--r--src/Propellor/Property/Munin.hs4
-rw-r--r--src/Propellor/Property/Network.hs70
-rw-r--r--src/Propellor/Property/OS.hs4
-rw-r--r--src/Propellor/Property/Obnam.hs7
-rw-r--r--src/Propellor/Property/OpenId.hs2
-rw-r--r--src/Propellor/Property/Pacman.hs68
-rw-r--r--src/Propellor/Property/Parted.hs219
-rw-r--r--src/Propellor/Property/Parted/Types.hs119
-rw-r--r--src/Propellor/Property/Partition.hs24
-rw-r--r--src/Propellor/Property/Reboot.hs19
-rw-r--r--src/Propellor/Property/Restic.hs202
-rw-r--r--src/Propellor/Property/Rsync.hs16
-rw-r--r--src/Propellor/Property/Sbuild.hs227
-rw-r--r--src/Propellor/Property/SiteSpecific/Branchable.hs30
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs15
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs231
-rw-r--r--src/Propellor/Property/Ssh.hs12
-rw-r--r--src/Propellor/Property/Sudo.hs24
-rw-r--r--src/Propellor/Property/Systemd.hs74
-rw-r--r--src/Propellor/Property/Timezone.hs21
-rw-r--r--src/Propellor/Property/Tor.hs34
-rw-r--r--src/Propellor/Property/Unbound.hs4
-rw-r--r--src/Propellor/Property/User.hs35
-rw-r--r--src/Propellor/Property/Versioned.hs124
-rw-r--r--src/Propellor/Property/XFCE.hs41
-rw-r--r--src/Propellor/Property/ZFS/Process.hs3
-rw-r--r--src/Propellor/Shim.hs2
-rw-r--r--src/Propellor/Spin.hs119
-rw-r--r--src/Propellor/Ssh.hs18
-rw-r--r--src/Propellor/Types.hs58
-rw-r--r--src/Propellor/Types/Bootloader.hs12
-rw-r--r--src/Propellor/Types/Chroot.hs2
-rw-r--r--src/Propellor/Types/CmdLine.hs1
-rw-r--r--src/Propellor/Types/ConfigurableValue.hs44
-rw-r--r--src/Propellor/Types/Core.hs7
-rw-r--r--src/Propellor/Types/Dns.hs23
-rw-r--r--src/Propellor/Types/Docker.hs2
-rw-r--r--src/Propellor/Types/Info.hs23
-rw-r--r--src/Propellor/Types/MetaTypes.hs28
-rw-r--r--src/Propellor/Types/OS.hs29
-rw-r--r--src/Propellor/Types/PartSpec.hs66
-rw-r--r--src/Propellor/Types/Result.hs3
-rw-r--r--src/Propellor/Types/ZFS.hs79
89 files changed, 3001 insertions, 1108 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 2c8fa95a..08af6878 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -1,8 +1,16 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Bootstrap (
+ Bootstrapper(..),
+ Builder(..),
+ defaultBootstrapper,
+ getBootstrapper,
bootstrapPropellorCommand,
checkBinaryCommand,
installGitCommand,
buildPropellor,
+ checkDepsCommand,
+ buildCommand,
) where
import Propellor.Base
@@ -14,74 +22,124 @@ import Data.List
type ShellCommand = String
+-- | Different ways that Propellor's dependencies can be installed,
+-- and propellor can be built. The default is `Robustly Cabal`
+--
+-- `Robustly Cabal` and `Robustly Stack` use the OS's native packages
+-- as much as possible to install Cabal, Stack, and propellor's build
+-- dependencies. When necessary, dependencies are built from source
+-- using Cabal or Stack rather than using the OS's native packages.
+--
+-- `OSOnly` uses the OS's native packages of Cabal and all of propellor's
+-- build dependencies. It may not work on all systems.
+data Bootstrapper = Robustly Builder | OSOnly
+ deriving (Show, Typeable)
+
+data Builder = Cabal | Stack
+ deriving (Show, Typeable)
+
+defaultBootstrapper :: Bootstrapper
+defaultBootstrapper = Robustly Cabal
+
+-- | Gets the Bootstrapper for the Host propellor is running on.
+getBootstrapper :: Propellor Bootstrapper
+getBootstrapper = go <$> askInfo
+ where
+ go NoInfoVal = defaultBootstrapper
+ go (InfoVal bs) = bs
+
+getBuilder :: Bootstrapper -> Builder
+getBuilder (Robustly b) = b
+getBuilder OSOnly = Cabal
+
-- Shell command line to ensure propellor is bootstrapped and ready to run.
-- Should be run inside the propellor config dir, and will install
-- all necessary build dependencies and build propellor.
-bootstrapPropellorCommand :: Maybe System -> ShellCommand
-bootstrapPropellorCommand msys = checkDepsCommand msys ++
+bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand
+bootstrapPropellorCommand bs msys = checkDepsCommand bs msys ++
"&& if ! test -x ./propellor; then "
- ++ buildCommand ++
- "; fi;" ++ checkBinaryCommand
+ ++ buildCommand bs ++
+ "; fi;" ++ checkBinaryCommand bs
-- Use propellor --check to detect if the local propellor binary has
-- stopped working (eg due to library changes), and must be rebuilt.
-checkBinaryCommand :: ShellCommand
-checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi"
+checkBinaryCommand :: Bootstrapper -> ShellCommand
+checkBinaryCommand bs = "if test -x ./propellor && ! ./propellor --check; then " ++ go (getBuilder bs) ++ "; fi"
where
- go = intercalate " && "
+ go Cabal = intercalate " && "
[ "cabal clean"
- , buildCommand
+ , buildCommand bs
+ ]
+ go Stack = intercalate " && "
+ [ "stack clean"
+ , buildCommand bs
]
-buildCommand :: ShellCommand
-buildCommand = intercalate " && "
- [ "cabal configure"
- , "cabal build propellor-config"
- , "ln -sf dist/build/propellor-config/propellor-config propellor"
- ]
+buildCommand :: Bootstrapper -> ShellCommand
+buildCommand bs = intercalate " && " (go (getBuilder bs))
+ where
+ go Cabal =
+ [ "cabal configure"
+ , "cabal build propellor-config"
+ , "ln -sf dist/build/propellor-config/propellor-config propellor"
+ ]
+ go Stack =
+ [ "stack build :propellor-config"
+ , "ln -sf $(stack path --dist-dir)/build/propellor-config/propellor-config propellor"
+ ]
--- Run cabal configure to check if all dependencies are installed;
--- if not, run the depsCommand.
-checkDepsCommand :: Maybe System -> ShellCommand
-checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi"
+-- Check if all dependencies are installed; if not, run the depsCommand.
+checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+checkDepsCommand bs sys = go (getBuilder bs)
+ where
+ go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
+ go Stack = "if ! stack build --dry-run >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi"
--- Install build dependencies of propellor.
---
--- First, try to install ghc, cabal, gnupg, and all haskell libraries that
--- propellor uses from OS packages.
+-- Install build dependencies of propellor, using the specified
+-- Bootstrapper.
--
+-- When bootstrapping Robustly, first try to install the builder,
+-- and all haskell libraries that propellor uses from OS packages.
-- Some packages may not be available in some versions of Debian
-- (eg, Debian wheezy lacks async), or propellor may need a newer version.
--- So, as a second step, cabal is used to install all dependencies.
+-- So, as a second step, any other dependencies are installed from source
+-- using the builder.
--
-- Note: May succeed and leave some deps not installed.
-depsCommand :: Maybe System -> ShellCommand
-depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true"
+depsCommand :: Bootstrapper -> Maybe System -> ShellCommand
+depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true"
where
- osinstall = case msys of
- Just (System (FreeBSD _) _) -> map pkginstall fbsddeps
- Just (System (Debian _ _) _) -> useapt
- Just (System (Buntish _) _) -> useapt
- -- assume a debian derived system when not specified
- Nothing -> useapt
-
- useapt = "apt-get update" : map aptinstall debdeps
-
- cabalinstall =
+ go (Robustly Cabal) = osinstall Cabal ++
[ "cabal update"
, "cabal install --only-dependencies"
+ ]
+ go (Robustly Stack) = osinstall Stack ++
+ [ "stack setup"
+ , "stack build --only-dependencies :propellor-config"
]
+ go OSOnly = osinstall Cabal
+
+ osinstall builder = case msys of
+ Just (System (FreeBSD _) _) -> map pkginstall (fbsddeps builder)
+ Just (System (ArchLinux) _) -> map pacmaninstall (archlinuxdeps builder)
+ Just (System (Debian _ _) _) -> useapt builder
+ Just (System (Buntish _) _) -> useapt builder
+ -- assume a Debian derived system when not specified
+ Nothing -> useapt builder
+
+ useapt builder = "apt-get update" : map aptinstall (debdeps builder)
aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p
pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p
+ pacmaninstall p = "pacman -S --noconfirm --needed " ++ p
-- This is the same deps listed in debian/control.
- debdeps =
+ debdeps Cabal =
[ "gnupg"
, "ghc"
, "cabal-install"
, "libghc-async-dev"
- , "libghc-missingh-dev"
+ , "libghc-split-dev"
, "libghc-hslogger-dev"
, "libghc-unix-compat-dev"
, "libghc-ansi-terminal-dev"
@@ -92,14 +150,19 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "libghc-exceptions-dev"
, "libghc-stm-dev"
, "libghc-text-dev"
- , "make"
+ , "libghc-hashable-dev"
+ ]
+ debdeps Stack =
+ [ "gnupg"
+ , "haskell-stack"
]
- fbsddeps =
+
+ fbsddeps Cabal =
[ "gnupg"
, "ghc"
, "hs-cabal-install"
, "hs-async"
- , "hs-MissingH"
+ , "hs-split"
, "hs-hslogger"
, "hs-unix-compat"
, "hs-ansi-terminal"
@@ -110,7 +173,35 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall])
, "hs-exceptions"
, "hs-stm"
, "hs-text"
- , "gmake"
+ , "hs-hashable"
+ ]
+ fbsddeps Stack =
+ [ "gnupg"
+ , "stack"
+ ]
+
+ archlinuxdeps Cabal =
+ [ "gnupg"
+ , "ghc"
+ , "cabal-install"
+ , "haskell-async"
+ , "haskell-split"
+ , "haskell-hslogger"
+ , "haskell-unix-compat"
+ , "haskell-ansi-terminal"
+ , "haskell-hackage-security"
+ , "haskell-ifelse"
+ , "haskell-network"
+ , "haskell-mtl"
+ , "haskell-transformers-base"
+ , "haskell-exceptions"
+ , "haskell-stm"
+ , "haskell-text"
+ , "hashell-hashable"
+ ]
+ archlinuxdeps Stack =
+ [ "gnupg"
+ , "stack"
]
installGitCommand :: Maybe System -> ShellCommand
@@ -121,31 +212,39 @@ installGitCommand msys = case msys of
[ "ASSUME_ALWAYS_YES=yes pkg update"
, "ASSUME_ALWAYS_YES=yes pkg install git"
]
+ (Just (System (ArchLinux) _)) -> use
+ [ "pacman -S --noconfirm --needed git"]
-- assume a debian derived system when not specified
Nothing -> use apt
where
- use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi"
+ use cmds = "if ! git --version >/dev/null 2>&1; then " ++ intercalate " && " cmds ++ "; fi"
apt =
[ "apt-get update"
, "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git"
]
+-- Build propellor, and symlink the built binary to ./propellor.
+--
+-- When the Host has a Buildsystem specified it is used. If none is
+-- specified, look at git config propellor.buildsystem.
buildPropellor :: Maybe Host -> IO ()
-buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $
+buildPropellor mh = unlessM (actionMessage "Propellor build" build) $
errorMessage "Propellor build failed!"
where
msys = case fmap (fromInfo . hostInfo) mh of
Just (InfoVal sys) -> Just sys
_ -> Nothing
--- Build propellor using cabal or stack, and symlink propellor to the
--- built binary.
-build :: Maybe System -> IO Bool
-build msys = catchBoolIO $ do
- bs <- getGitConfigValue "propellor.buildsystem"
- case bs of
- Just "stack" -> stackBuild msys
- _ -> cabalBuild msys
+ build = catchBoolIO $ do
+ case fromInfo (maybe mempty hostInfo mh) of
+ NoInfoVal -> do
+ bs <- getGitConfigValue "propellor.buildsystem"
+ case bs of
+ Just "stack" -> stackBuild msys
+ _ -> cabalBuild msys
+ InfoVal bs -> case getBuilder bs of
+ Cabal -> cabalBuild msys
+ Stack -> stackBuild msys
-- For speed, only runs cabal configure when it's not been run before.
-- If the build fails cabal may need to have configure re-run.
@@ -178,7 +277,7 @@ cabalBuild msys = do
, case msys of
Nothing -> return False
Just sys ->
- boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))]
+ boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))]
<&&> cabal ["configure"]
)
cabal_build = cabal ["build", "propellor-config"]
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index fc256109..bd01b34c 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -19,26 +19,41 @@ import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
+import Utility.FileSystemEncoding
usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
[ "Usage:"
- , " propellor --init"
- , " propellor"
- , " propellor hostname"
- , " propellor --spin targethost [--via relayhost]"
- , " propellor --add-key keyid"
- , " propellor --rm-key keyid"
- , " propellor --list-fields"
- , " propellor --dump field context"
- , " propellor --edit field context"
- , " propellor --set field context"
- , " propellor --unset field context"
- , " propellor --unset-unused"
- , " propellor --merge"
- , " propellor --build"
- , " propellor --check"
- ]
+ , " with no arguments, provision the current host"
+ , ""
+ , " --init"
+ , " initialize ~/.propellor"
+ , " hostname"
+ , " provision the current host as if it had the specified hostname"
+ , " --spin targethost [--via relayhost]"
+ , " provision the specified host"
+ , " --build"
+ , " recompile using your current config"
+ , " --add-key keyid"
+ , " add an additional signing key to the private data"
+ , " --rm-key keyid"
+ , " remove a signing key from the private data"
+ , " --list-fields"
+ , " list private data fields"
+ , " --set field context"
+ , " set a private data field"
+ , " --unset field context"
+ , " clear a private data field"
+ , " --unset-unused"
+ , " clear unused fields from the private data"
+ , " --dump field context"
+ , " show the content of a private data field"
+ , " --edit field context"
+ , " edit the content of a private data field"
+ , " --merge"
+ , " combine multiple spins into a single git commit"
+ , " --check"
+ , " double-check that propellor can actually run here"]
usageError :: [String] -> IO a
usageError ps = do
@@ -54,6 +69,7 @@ processCmdLine = go =<< getArgs
<$> mapM hostname (reverse hs)
<*> pure (Just r)
_ -> Spin <$> mapM hostname ps <*> pure Nothing
+ go ("--build":[]) = return Build
go ("--add-key":k:[]) = return $ AddKey k
go ("--rm-key":k:[]) = return $ RmKey k
go ("--set":f:c:[]) = withprivfield f c Set
@@ -94,6 +110,8 @@ data CanRebuild = CanRebuild | NoRebuild
-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = withConcurrentOutput $ do
+ useFileSystemEncoding
+ setupGpgEnv
Shim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
@@ -102,6 +120,7 @@ defaultMain hostlist = withConcurrentOutput $ do
where
go cr (Serialized cmdline) = go cr cmdline
go _ Check = return ()
+ go cr Build = buildFirst Nothing cr Build $ return ()
go _ (Set field context) = setPrivData field context
go _ (Unset field context) = unsetPrivData field context
go _ (UnsetUnused) = unsetPrivDataUnused hostlist
@@ -186,7 +205,7 @@ updateFirst h canrebuild cmdline next = ifM hasOrigin
, next
)
--- If changes can be fetched from origin, Builds propellor (when allowed)
+-- If changes can be fetched from origin, builds propellor (when allowed)
-- and re-execs the updated propellor binary to continue.
-- Otherwise, runs the IO action to continue.
updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 26194456..a805add8 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -51,15 +51,30 @@ propagateContainer
)
=> String
-> c
+ -> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
-propagateContainer containername c prop = prop
+propagateContainer containername c wanted prop = prop
`addChildren` map convert (containerProperties c)
where
convert p =
- let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
+ let n = property'' (getDesc p) (getSatisfy p) :: Property UnixLike
n' = n
`setInfoProperty` mapInfo (forceHostContext containername)
- (propagatableInfo (getInfo p))
+ (propagatableInfo wanted (getInfo p))
`addChildren` map convert (getChildren p)
in toChildProperty n'
+
+-- | Filters out parts of the Info that should not propagate out of a
+-- container.
+propagatableInfo :: (PropagateInfo -> Bool) -> Info -> Info
+propagatableInfo wanted (Info l) = Info $
+ filter (\(InfoEntry a) -> wanted (propagateInfo a)) l
+
+normalContainerInfo :: PropagateInfo -> Bool
+normalContainerInfo PropagatePrivData = True
+normalContainerInfo (PropagateInfo b) = b
+
+onlyPrivData :: PropagateInfo -> Bool
+onlyPrivData PropagatePrivData = True
+onlyPrivData (PropagateInfo _) = False
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index 21a9cdb7..f42c0575 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -47,10 +47,10 @@ disthead = distdir </> "head"
upstreambranch :: String
upstreambranch = "upstream/master"
--- Using the github mirror of the main propellor repo because
+-- Using the joeyh.name mirror of the main propellor repo because
-- it is accessible over https for better security.
netrepo :: String
-netrepo = "https://github.com/joeyh/propellor.git"
+netrepo = "https://git.joeyh.name/git/propellor.git"
dotPropellor :: IO FilePath
dotPropellor = do
@@ -316,7 +316,7 @@ minimalConfig = do
]
stackResolver :: String
-stackResolver = "lts-5.10"
+stackResolver = "lts-8.22"
fullClone :: IO Result
fullClone = do
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 8958da6b..b4dc66ce 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -8,6 +8,8 @@ module Propellor.Engine (
fromHost,
fromHost',
onlyProcess,
+ chainPropellor,
+ runChainPropellor,
) where
import System.Exit
@@ -17,7 +19,9 @@ import "mtl" Control.Monad.RWS.Strict
import System.PosixCompat
import System.Posix.IO
import System.FilePath
+import System.Console.Concurrent
import Control.Applicative
+import Control.Concurrent.Async
import Prelude
import Propellor.Types
@@ -28,6 +32,8 @@ import Propellor.Exception
import Propellor.Info
import Utility.Exception
import Utility.Directory
+import Utility.Process
+import Utility.PartialPrelude
-- | Gets the Properties of a Host, and ensures them all,
-- with nice display of what's being done.
@@ -66,7 +72,9 @@ ensureChildProperties ps = ensure ps NoChange
ensure [] rs = return rs
ensure (p:ls) rs = do
hn <- asks hostName
- r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)
+ r <- maybe (pure NoChange)
+ (actionMessageOn hn (getDesc p) . catchPropellor)
+ (getSatisfy p)
ensure ls (r <> rs)
-- | Lifts an action into the context of a different host.
@@ -89,8 +97,59 @@ onlyProcess lockfile a = bracket lock unlock (const a)
lock = do
createDirectoryIfMissing True (takeDirectory lockfile)
l <- createFile lockfile stdFileMode
+ setFdOption l CloseOnExec True
setLock l (WriteLock, AbsoluteSeek, 0, 0)
`catchIO` const alreadyrunning
return l
unlock = closeFd
alreadyrunning = error "Propellor is already running on this host!"
+
+-- | Chains to a propellor sub-Process, forwarding its output on to the
+-- display, except for the last line which is a Result.
+chainPropellor :: CreateProcess -> IO Result
+chainPropellor p =
+ -- We want to use outputConcurrent to display output
+ -- as it's received. If only stdout were captured,
+ -- concurrent-output would buffer all outputConcurrent.
+ -- Also capturing stderr avoids that problem.
+ withOEHandles createProcessSuccess p $ \(outh, errh) -> do
+ (r, ()) <- processChainOutput outh
+ `concurrently` forwardChainError errh
+ return r
+
+-- | Reads and displays each line from the Handle, except for the last line
+-- which is a Result.
+processChainOutput :: Handle -> IO Result
+processChainOutput h = go Nothing
+ where
+ go lastline = do
+ v <- catchMaybeIO (hGetLine h)
+ case v of
+ Nothing -> case lastline of
+ Nothing -> do
+ return FailedChange
+ Just l -> case readish l of
+ Just r -> pure r
+ Nothing -> do
+ outputConcurrent (l ++ "\n")
+ return FailedChange
+ Just s -> do
+ outputConcurrent $
+ maybe "" (\l -> if null l then "" else l ++ "\n") lastline
+ go (Just s)
+
+forwardChainError :: Handle -> IO ()
+forwardChainError h = do
+ v <- catchMaybeIO (hGetLine h)
+ case v of
+ Nothing -> return ()
+ Just s -> do
+ errorConcurrent (s ++ "\n")
+ forwardChainError h
+
+-- | Used by propellor sub-Processes that are run by chainPropellor.
+runChainPropellor :: Host -> Propellor Result -> IO ()
+runChainPropellor h a = do
+ r <- runPropellor h a
+ flushConcurrentOutput
+ putStrLn $ "\n" ++ show r
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index 30dfd5ad..ad74bfa8 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -46,7 +46,7 @@ ensureProperty
=> OuterMetaTypesWitness outer
-> Property (MetaTypes inner)
-> Propellor Result
-ensureProperty _ = catchPropellor . getSatisfy
+ensureProperty _ = maybe (return NoChange) catchPropellor . getSatisfy
-- The name of this was chosen to make type errors a bit more understandable.
type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool
@@ -62,7 +62,7 @@ property'
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' d a =
- let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty
+ let p = Property sing d (Just (a (outerMetaTypesWitness p))) mempty mempty
in p
-- | Used to provide the metatypes of a Property to calls to
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index fd2fca79..c48bc060 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -1,8 +1,9 @@
module Propellor.Gpg where
import System.IO
+import System.Posix.IO
+import System.Posix.Terminal
import Data.Maybe
-import Data.List.Utils
import Control.Monad
import Control.Applicative
import Prelude
@@ -16,9 +17,32 @@ import Utility.Process.NonConcurrent
import Utility.Monad
import Utility.Misc
import Utility.Tmp
-import Utility.FileSystemEncoding
import Utility.Env
import Utility.Directory
+import Utility.Split
+import Utility.Exception
+
+-- | When at a tty, set GPG_TTY to point to the tty device. This is needed
+-- so that when gpg is run with stio connected to a pipe, it is still able
+-- to display password prompts at the console.
+--
+-- This should not prevent gpg from using the GUI for prompting when one is
+-- available.
+setupGpgEnv :: IO ()
+setupGpgEnv = checkhandles [stdInput, stdOutput, stdError]
+ where
+ checkhandles [] = return ()
+ checkhandles (h:hs) = do
+ isterm <- queryTerminal h
+ if isterm
+ then do
+ v <- tryNonAsync $ getTerminalName h
+ case v of
+ Right ttyname ->
+ -- do not overwrite
+ setEnv "GPG_TTY" ttyname False
+ Left _ -> checkhandles hs
+ else checkhandles hs
type KeyId = String
@@ -183,7 +207,7 @@ gpgDecrypt :: FilePath -> IO String
gpgDecrypt f = do
gpgbin <- getGpgBin
ifM (doesFileExist f)
- ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding)
+ ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing Nothing
, return ""
)
@@ -201,6 +225,4 @@ gpgEncrypt f s = do
encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing
viaTmp writeFile f encrypted
where
- writer h = do
- fileEncoding h
- hPutStr h s
+ writer h = hPutStr h s
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 3d7f07a5..ed6c2d85 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -3,6 +3,7 @@
module Propellor.Info (
osDebian,
osBuntish,
+ osArchLinux,
osFreeBSD,
setInfoProperty,
addInfoProperty,
@@ -83,13 +84,13 @@ askInfo = asks (fromInfo . hostInfo)
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
--- > & osDebian (Stable "jessie") X86_64
+-- > & osDebian (Stable "stretch") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = osDebian' Linux
-- Use to specify a different `DebianKernel` than the default `Linux`
--
--- > & osDebian' KFreeBSD (Stable "jessie") X86_64
+-- > & osDebian' KFreeBSD (Stable "stretch") X86_64
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
@@ -106,6 +107,10 @@ osBuntish release arch = tightenTargets $ os (System (Buntish release) arch)
osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD)
osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch)
+-- | Specifies that a host's operating system is Arch Linux
+osArchLinux :: Architecture -> Property (HasInfo + ArchLinux)
+osArchLinux arch = tightenTargets $ os (System (ArchLinux) arch)
+
os :: System -> Property (HasInfo + UnixLike)
os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 97573516..0f42e417 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -5,6 +5,8 @@
-- the messages will be displayed sequentially.
module Propellor.Message (
+ Trace(..),
+ parseTrace,
getMessageHandle,
isConsole,
forceConsole,
@@ -14,7 +16,6 @@ module Propellor.Message (
infoMessage,
errorMessage,
stopPropellorMessage,
- processChainOutput,
messagesDone,
createProcessConcurrent,
withConcurrentOutput,
@@ -22,6 +23,7 @@ module Propellor.Message (
import System.Console.ANSI
import System.IO
+import Control.Monad.IfElse
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent
@@ -31,12 +33,26 @@ import Prelude
import Propellor.Types
import Propellor.Types.Exception
-import Utility.PartialPrelude
import Utility.Monad
+import Utility.Env
import Utility.Exception
+import Utility.PartialPrelude
+
+-- | Serializable tracing. Export `PROPELLOR_TRACE=1` in the environment to
+-- make propellor emit these to stdout, in addition to its other output.
+data Trace
+ = ActionStart (Maybe HostName) Desc
+ | ActionEnd (Maybe HostName) Desc Result
+ deriving (Read, Show)
+
+-- | Given a line read from propellor, if it's a serialized Trace,
+-- parses it.
+parseTrace :: String -> Maybe Trace
+parseTrace = readish
data MessageHandle = MessageHandle
{ isConsole :: Bool
+ , traceEnabled :: Bool
}
-- | A shared global variable for the MessageHandle.
@@ -45,11 +61,16 @@ globalMessageHandle :: MVar MessageHandle
globalMessageHandle = unsafePerformIO $
newMVar =<< MessageHandle
<$> catchDefaultIO False (hIsTerminalDevice stdout)
+ <*> ((== Just "1") <$> getEnv "PROPELLOR_TRACE")
-- | Gets the global MessageHandle.
getMessageHandle :: IO MessageHandle
getMessageHandle = readMVar globalMessageHandle
+trace :: Trace -> IO ()
+trace t = whenM (traceEnabled <$> getMessageHandle) $
+ putStrLn $ show t
+
-- | Force console output. This can be used when stdout is not directly
-- connected to a console, but is eventually going to be displayed at a
-- console.
@@ -65,16 +86,17 @@ whenConsole s = ifM (isConsole <$> getMessageHandle)
-- | Shows a message while performing an action, with a colored status
-- display.
-actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r
+actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r
actionMessage = actionMessage' Nothing
-- | Shows a message while performing an action on a specified host,
-- with a colored status display.
-actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r
+actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r
actionMessageOn = actionMessage' . Just
-actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
+actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r
actionMessage' mhn desc a = do
+ liftIO $ trace $ ActionStart mhn desc
liftIO $ outputConcurrent
=<< whenConsole (setTitleCode $ "propellor: " ++ desc)
@@ -88,6 +110,7 @@ actionMessage' mhn desc a = do
, let (msg, intensity, color) = getActionResult r
in colorLine intensity color msg
]
+ liftIO $ trace $ ActionEnd mhn desc (toResult r)
return r
where
@@ -102,7 +125,7 @@ actionMessage' mhn desc a = do
warningMessage :: MonadIO m => String -> m ()
warningMessage s = liftIO $
- outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
+ errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
infoMessage :: MonadIO m => [String] -> m ()
infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
@@ -113,7 +136,7 @@ infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
-- property fail. Propellor will continue to the next property.
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
- outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+ errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
-- Normally this exception gets caught and is not displayed,
-- and propellor continues. So it's only displayed if not
-- caught, and so we say, cannot continue.
@@ -142,27 +165,6 @@ colorLine intensity color msg = concat <$> sequence
, pure "\n"
]
--- | Reads and displays each line from the Handle, except for the last line
--- which is a Result.
-processChainOutput :: Handle -> IO Result
-processChainOutput h = go Nothing
- where
- go lastline = do
- v <- catchMaybeIO (hGetLine h)
- case v of
- Nothing -> case lastline of
- Nothing -> do
- return FailedChange
- Just l -> case readish l of
- Just r -> pure r
- Nothing -> do
- outputConcurrent (l ++ "\n")
- return FailedChange
- Just s -> do
- outputConcurrent $
- maybe "" (\l -> if null l then "" else l ++ "\n") lastline
- go (Just s)
-
-- | Called when all messages about properties have been printed.
messagesDone :: IO ()
messagesDone = outputConcurrent
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 2e9cdbab..516eda03 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -57,7 +57,6 @@ import Utility.Misc
import Utility.FileMode
import Utility.Env
import Utility.Table
-import Utility.FileSystemEncoding
import Utility.Directory
-- | Allows a Property to access the value of a specific PrivDataField,
@@ -171,7 +170,6 @@ getPrivData field context m = do
setPrivData :: PrivDataField -> Context -> IO ()
setPrivData field context = do
putStrLn "Enter private data on stdin; ctrl-D when done:"
- fileEncoding stdin
setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin
unsetPrivData :: PrivDataField -> Context -> IO ()
@@ -274,7 +272,7 @@ readPrivData :: String -> PrivMap
readPrivData = fromMaybe M.empty . readish
readPrivDataFile :: FilePath -> IO PrivMap
-readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f
+readPrivDataFile f = readPrivData <$> readFileStrict f
makePrivDataDir :: IO ()
makePrivDataDir = createDirectoryIfMissing False privDataDir
@@ -283,10 +281,10 @@ newtype PrivInfo = PrivInfo
{ fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) }
deriving (Eq, Ord, Show, Typeable, Monoid)
--- PrivInfo is propagated out of containers, so that propellor can see which
--- hosts need it.
+-- PrivInfo always propagates out of containers, so that propellor
+-- can see which hosts need it.
instance IsInfo PrivInfo where
- propagateInfo _ = True
+ propagateInfo _ = PropagatePrivData
-- | Sets the context of any privdata that uses HostContext to the
-- provided name.
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index ae4fc914..55e688ab 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -16,7 +16,6 @@ module Propellor.Property (
, check
, fallback
, revert
- , applyToList
-- * Property descriptions
, describe
, (==>)
@@ -51,10 +50,10 @@ import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
-import qualified Data.Hash.MD5 as MD5
+import Data.Maybe
import Data.List
+import Data.Hashable
import Control.Applicative
-import Data.Foldable hiding (and, elem)
import Prelude
import Propellor.Types
@@ -66,8 +65,8 @@ import Propellor.Info
import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
-import Utility.Misc
import Utility.Directory
+import Utility.Misc
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
@@ -120,13 +119,15 @@ onChange
-> CombinedType x y
onChange = combineWith combiner revertcombiner
where
- combiner p hook = do
+ combiner (Just p) (Just hook) = Just $ do
r <- p
case r of
MadeChange -> do
r' <- hook
return $ r <> r'
_ -> return r
+ combiner (Just p) Nothing = Just p
+ combiner Nothing _ = Nothing
revertcombiner = (<>)
-- | Same as `onChange` except that if property y fails, a flag file
@@ -144,24 +145,30 @@ onChangeFlagOnFail
-> CombinedType x y
onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
where
- combiner s1 s2 = do
+ combiner (Just s1) s2 = Just $ do
r1 <- s1
case r1 of
MadeChange -> flagFailed s2
_ -> ifM (liftIO $ doesFileExist flagfile)
- (flagFailed s2
+ ( flagFailed s2
, return r1
)
+ combiner Nothing _ = Nothing
+
revertcombiner = (<>)
- flagFailed s = do
+
+ flagFailed (Just s) = do
r <- s
liftIO $ case r of
FailedChange -> createFlagFile
_ -> removeFlagFile
return r
+ flagFailed Nothing = return NoChange
+
createFlagFile = unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
writeFile flagfile ""
+
removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
-- | Changes the description of a property.
@@ -178,11 +185,13 @@ infixl 1 ==>
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
fallback = combineWith combiner revertcombiner
where
- combiner a1 a2 = do
+ combiner (Just a1) (Just a2) = Just $ do
r <- a1
if r == FailedChange
then a2
else return r
+ combiner (Just a1) Nothing = Just a1
+ combiner Nothing _ = Nothing
revertcombiner = (<>)
-- | Indicates that a Property may change a particular file. When the file
@@ -220,12 +229,12 @@ changesFile p f = checkResult getstat comparestat p
-- Changes to mtime etc that do not change file content are treated as
-- NoChange.
changesFileContent :: Checkable p i => p i -> FilePath -> Property i
-changesFileContent p f = checkResult getmd5 comparemd5 p
+changesFileContent p f = checkResult gethash comparehash p
where
- getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f
- comparemd5 oldmd5 = do
- newmd5 <- getmd5
- return $ if oldmd5 == newmd5 then NoChange else MadeChange
+ gethash = catchMaybeIO $ hash <$> readFileStrict f
+ comparehash oldhash = do
+ newhash <- gethash
+ return $ if oldhash == newhash then NoChange else MadeChange
-- | Determines if the first file is newer than the second file.
--
@@ -263,7 +272,7 @@ isNewerThan x y = do
--
-- For example:
--
--- > upgraded :: UnixLike
+-- > upgraded :: Property (DebianLike + FreeBSD)
-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
-- > `describe` "OS upgraded"
--
@@ -292,9 +301,9 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
-- are added as children, so their info will propigate.
c = withOS (getDesc a) $ \_ o ->
if matching o a
- then getSatisfy a
+ then maybe (pure NoChange) id (getSatisfy a)
else if matching o b
- then getSatisfy b
+ then maybe (pure NoChange) id (getSatisfy b)
else unsupportedOS'
matching Nothing _ = False
matching (Just o) p =
@@ -308,8 +317,8 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
--
-- > myproperty :: Property Debian
-- > myproperty = withOS "foo installed" $ \w o -> case o of
--- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ...
--- > (Just (System (Debian suite) arch)) -> ensureProperty w ...
+-- > (Just (System (Debian kernel (Stable release)) arch)) -> ensureProperty w ...
+-- > (Just (System (Debian kernel suite) arch)) -> ensureProperty w ...
-- > _ -> unsupportedOS'
--
-- Note that the operating system specifics may not be declared for all hosts,
@@ -343,22 +352,17 @@ unsupportedOS' = go =<< getOS
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
--- | Apply a property to each element of a list.
-applyToList
- :: (Foldable t, Functor t, Combines p p, p ~ CombinedType p p)
- => (b -> p)
- -> t b
- -> p
-prop `applyToList` xs = Data.Foldable.foldr1 before $ prop <$> xs
-
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
+-- | A no-op property.
+--
+-- This is the same as `mempty` from the `Monoid` instance.
doNothing :: SingI t => Property (MetaTypes t)
-doNothing = property "noop property" noChange
+doNothing = mempty
-- | Registers an action that should be run at the very end, after
-- propellor has checks all the properties of a host.
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index f321143f..854d0eaa 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -64,6 +64,24 @@ modEnabled modname = enable <!> disable
`onChange` reloaded
isenabled = boolSystem "a2query" [Param "-q", Param "-m", Param modname]
+-- | Control whether an apache configuration file is enabled.
+--
+-- The String is the base name of the configuration, eg "charset" or "gitweb".
+confEnabled :: String -> RevertableProperty DebianLike DebianLike
+confEnabled confname = enable <!> disable
+ where
+ enable = check (not <$> isenabled)
+ (cmdProperty "a2enconf" ["--quiet", confname])
+ `describe` ("apache configuration enabled " ++ confname)
+ `requires` installed
+ `onChange` reloaded
+ disable = check isenabled
+ (cmdProperty "a2disconf" ["--quiet", confname])
+ `describe` ("apache configuration disabled " ++ confname)
+ `requires` installed
+ `onChange` reloaded
+ isenabled = boolSystem "a2query" [Param "-q", Param "-c", Param confname]
+
-- | Make apache listen on the specified ports.
--
-- Note that ports are also specified inside a site's config file,
@@ -72,7 +90,7 @@ listenPorts :: [Port] -> Property DebianLike
listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps
`onChange` restarted
where
- portline port = "Listen " ++ fromPort port
+ portline port = "Listen " ++ val port
-- This is a list of config files because different versions of apache
-- use different filenames. Propellor simply writes them all.
@@ -135,8 +153,8 @@ virtualHost domain port docroot = virtualHost' domain port docroot []
-- | Like `virtualHost` but with additional config lines added.
virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
virtualHost' domain port docroot addedcfg = siteEnabled domain $
- [ "<VirtualHost *:" ++ fromPort port ++ ">"
- , "ServerName " ++ domain ++ ":" ++ fromPort port
+ [ "<VirtualHost *:" ++ val port ++ ">"
+ , "ServerName " ++ domain ++ ":" ++ val port
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
@@ -171,7 +189,7 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
`requires` modEnabled "ssl"
`before` setuphttps
teardown = siteDisabled domain
- setuphttp = siteEnabled' domain $
+ setuphttp = (siteEnabled' domain $
-- The sslconffile is only created after letsencrypt gets
-- the cert. The "*" is needed to make apache not error
-- when the file doesn't exist.
@@ -183,27 +201,27 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
, "RewriteRule ^/.well-known/(.*) - [L]"
-- Everything else redirects to https
, "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]"
- ]
+ ])
+ `requires` File.dirExists (takeDirectory cf)
setuphttps = LetsEncrypt.letsEncrypt letos domain docroot
`onChange` postsetuphttps
postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props
- & File.dirExists (takeDirectory cf)
& File.hasContent cf sslvhost
`onChange` reloaded
-- always reload since the cert has changed
& reloaded
where
- cf = sslconffile "letsencrypt"
sslvhost = vhost (Port 443)
[ "SSLEngine on"
, "SSLCertificateFile " ++ LetsEncrypt.certFile domain
, "SSLCertificateKeyFile " ++ LetsEncrypt.privKeyFile domain
, "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain
]
+ cf = sslconffile "letsencrypt"
sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf"
vhost p ls =
- [ "<VirtualHost *:" ++ fromPort p ++">"
- , "ServerName " ++ domain ++ ":" ++ fromPort p
+ [ "<VirtualHost *:" ++ val p ++">"
+ , "ServerName " ++ domain ++ ":" ++ val p
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 196fb345..5630d83a 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module Propellor.Property.Apt where
import Data.Maybe
import Data.List
+import Data.Typeable
import System.IO
import Control.Monad
import Control.Applicative
@@ -13,6 +15,40 @@ import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.File (Line)
+import Propellor.Types.Info
+
+data HostMirror = HostMirror Url
+ deriving (Eq, Show, Typeable)
+
+data HostAptProxy = HostAptProxy Url
+ deriving (Eq, Show, Typeable)
+
+-- | Indicate host's preferred apt mirror
+mirror :: Url -> Property (HasInfo + UnixLike)
+mirror u = pureInfoProperty (u ++ " apt mirror selected")
+ (InfoVal (HostMirror u))
+
+getMirror :: Propellor Url
+getMirror = do
+ mirrorInfo <- getMirrorInfo
+ osInfo <- getOS
+ return $ case (osInfo, mirrorInfo) of
+ (_, Just (HostMirror u)) -> u
+ (Just (System (Debian _ _) _), _) ->
+ "http://deb.debian.org/debian"
+ (Just (System (Buntish _) _), _) ->
+ "mirror://mirrors.ubuntu.com/"
+ (Just (System dist _), _) ->
+ error ("no Apt mirror defined for " ++ show dist)
+ _ -> error "no Apt mirror defined for this host or OS"
+ where
+ getMirrorInfo :: Propellor (Maybe HostMirror)
+ getMirrorInfo = fromInfoVal <$> askInfo
+
+withMirror :: Desc -> (Url -> Property DebianLike) -> Property DebianLike
+withMirror desc mkp = property' desc $ \w -> do
+ u <- getMirror
+ ensureProperty w (mkp u)
sourcesList :: FilePath
sourcesList = "/etc/apt/sources.list"
@@ -37,8 +73,8 @@ stableUpdatesSuite (Stable s) = Just (s ++ "-updates")
stableUpdatesSuite _ = Nothing
debLine :: String -> Url -> [Section] -> Line
-debLine suite mirror sections = unwords $
- ["deb", mirror, suite] ++ sections
+debLine suite url sections = unwords $
+ ["deb", url, suite] ++ sections
srcLine :: Line -> Line
srcLine l = case words l of
@@ -61,11 +97,8 @@ binandsrc url suite = catMaybes
bs <- backportSuite suite
return $ debLine bs url stdSections
-debCdn :: SourcesGenerator
-debCdn = binandsrc "http://httpredir.debian.org/debian"
-
-kernelOrg :: SourcesGenerator
-kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
+stdArchiveLines :: Propellor SourcesGenerator
+stdArchiveLines = return . binandsrc =<< getMirror
-- | Only available for Stable and Testing
securityUpdates :: SourcesGenerator
@@ -75,11 +108,9 @@ securityUpdates suite
in [l, srcLine l]
| otherwise = []
--- | Makes sources.list have a standard content using the Debian mirror CDN,
--- with the Debian suite configured by the os.
---
--- Since the CDN is sometimes unreliable, also adds backup lines using
--- kernel.org.
+-- | Makes sources.list have a standard content using the Debian mirror CDN
+-- (or other host specified using the `mirror` property), with the
+-- Debian suite configured by the os.
stdSourcesList :: Property Debian
stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
(Just (System (Debian _ suite) _)) ->
@@ -94,11 +125,62 @@ stdSourcesListFor suite = stdSourcesList' suite []
-- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/>
stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian
-stdSourcesList' suite more = tightenTargets $ setSourcesList
- (concatMap (\gen -> gen suite) generators)
- `describe` ("standard sources.list for " ++ show suite)
+stdSourcesList' suite more = tightenTargets $
+ withMirror desc $ \u -> setSourcesList
+ (concatMap (\gen -> gen suite) (generators u))
where
- generators = [debCdn, kernelOrg, securityUpdates] ++ more
+ generators u = [binandsrc u, securityUpdates] ++ more
+ desc = ("standard sources.list for " ++ show suite)
+
+type PinPriority = Int
+
+-- | Adds an apt source for a suite, and pins that suite to a given pin value
+-- (see apt_preferences(5)). Revert to drop the source and unpin the suite.
+--
+-- If the requested suite is the host's OS suite, the suite is pinned, but no
+-- source is added. That apt source should already be available, or you can use
+-- a property like 'Apt.stdSourcesList'.
+suiteAvailablePinned
+ :: DebianSuite
+ -> PinPriority
+ -> RevertableProperty Debian Debian
+suiteAvailablePinned s pin = available <!> unavailable
+ where
+ available :: Property Debian
+ available = tightenTargets $ combineProperties (desc True) $ props
+ & File.hasContent prefFile (suitePinBlock "*" s pin)
+ & setSourcesFile
+
+ unavailable :: Property Debian
+ unavailable = tightenTargets $ combineProperties (desc False) $ props
+ & File.notPresent sourcesFile
+ `onChange` update
+ & File.notPresent prefFile
+
+ setSourcesFile :: Property Debian
+ setSourcesFile = tightenTargets $ withMirror (desc True) $ \u ->
+ withOS (desc True) $ \w o -> case o of
+ (Just (System (Debian _ hostSuite) _))
+ | s /= hostSuite -> ensureProperty w $
+ File.hasContent sourcesFile (sources u)
+ `onChange` update
+ _ -> noChange
+
+ -- Unless we are pinning a backports suite, filter out any backports
+ -- sources that were added by our generators. The user probably doesn't
+ -- want those to be pinned to the same value
+ sources u = dropBackports $ concatMap (\gen -> gen s) (generators u)
+ where
+ dropBackports
+ | "-backports" `isSuffixOf` (showSuite s) = id
+ | otherwise = filter (not . isInfixOf "-backports")
+
+ generators u = [binandsrc u, securityUpdates]
+ prefFile = "/etc/apt/preferences.d/20" ++ showSuite s ++ ".pref"
+ sourcesFile = "/etc/apt/sources.list.d/" ++ showSuite s ++ ".list"
+
+ desc True = "Debian " ++ showSuite s ++ " pinned, priority " ++ show pin
+ desc False = "Debian " ++ showSuite s ++ " not pinned"
setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
@@ -196,6 +278,50 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
where
cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"
+-- | The name of a package, a glob to match the names of packages, or a regexp
+-- surrounded by slashes to match the names of packages. See
+-- apt_preferences(5), "Regular expressions and glob(7) syntax"
+type AptPackagePref = String
+
+-- | Pins a list of packages, package wildcards and/or regular expressions to a
+-- list of suites and corresponding pin priorities (see apt_preferences(5)).
+-- Revert to unpin.
+--
+-- Each package, package wildcard or regular expression will be pinned to all of
+-- the specified suites.
+--
+-- Note that this will have no effect unless there is an apt source for each of
+-- the suites. One way to add an apt source is 'Apt.suiteAvailablePinned'.
+--
+-- For example, to obtain Emacs Lisp addon packages not present in your release
+-- of Debian from testing, falling back to sid if they're not available in
+-- testing, you could use
+--
+-- > & Apt.suiteAvailablePinned Testing (-10)
+-- > & Apt.suiteAvailablePinned Unstable (-10)
+-- > & ["elpa-*"] `Apt.pinnedTo` [(Testing, 100), (Unstable, 50)]
+pinnedTo
+ :: [AptPackagePref]
+ -> [(DebianSuite, PinPriority)]
+ -> RevertableProperty Debian Debian
+pinnedTo ps pins = mconcat (map (\p -> pinnedTo' p pins) ps)
+ `describe` unwords (("pinned to " ++ showSuites):ps)
+ where
+ showSuites = intercalate "," $ showSuite . fst <$> pins
+
+pinnedTo'
+ :: AptPackagePref
+ -> [(DebianSuite, PinPriority)]
+ -> RevertableProperty Debian Debian
+pinnedTo' p pins =
+ (tightenTargets $ prefFile `File.hasContent` prefs)
+ <!> (tightenTargets $ File.notPresent prefFile)
+ where
+ prefs = foldr step [] pins
+ step (suite, pin) ls = ls ++ suitePinBlock p suite pin ++ [""]
+ prefFile = "/etc/apt/preferences.d/10propellor_"
+ ++ File.configFileName p <.> "pref"
+
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
robustly :: Property DebianLike -> Property DebianLike
@@ -349,5 +475,40 @@ hasForeignArch arch = check notAdded (add `before` update)
add = cmdProperty "dpkg" ["--add-architecture", arch]
`assume` MadeChange
+-- | Disable the use of PDiffs for machines with high-bandwidth connections.
+noPDiffs :: Property DebianLike
+noPDiffs = tightenTargets $ "/etc/apt/apt.conf.d/20pdiffs" `File.hasContent`
+ [ "Acquire::PDiffs \"false\";" ]
+
+suitePin :: DebianSuite -> String
+suitePin s = prefix s ++ showSuite s
+ where
+ prefix (Stable _) = "n="
+ prefix _ = "a="
+
+suitePinBlock :: AptPackagePref -> DebianSuite -> PinPriority -> [Line]
+suitePinBlock p suite pin =
+ [ "Explanation: This file added by propellor"
+ , "Package: " ++ p
+ , "Pin: release " ++ suitePin suite
+ , "Pin-Priority: " ++ val pin
+ ]
+
dpkgStatus :: FilePath
dpkgStatus = "/var/lib/dpkg/status"
+
+-- | Set apt's proxy
+proxy :: Url -> Property (HasInfo + DebianLike)
+proxy u = tightenTargets $
+ proxyInfo `before` proxyConfig `describe` desc
+ where
+ proxyInfo = pureInfoProperty desc (InfoVal (HostAptProxy u))
+ proxyConfig = "/etc/apt/apt.conf.d/20proxy" `File.hasContent`
+ [ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]
+ desc = (u ++ " apt proxy selected")
+
+-- | Cause apt to proxy downloads via an apt cacher on localhost
+useLocalCacher :: Property (HasInfo + DebianLike)
+useLocalCacher = proxy "http://localhost:3142"
+ `requires` serviceInstalledRunning "apt-cacher-ng"
+ `describe` "apt uses local apt cacher"
diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs
index 49fa9fa7..a8f7db15 100644
--- a/src/Propellor/Property/Apt/PPA.hs
+++ b/src/Propellor/Property/Apt/PPA.hs
@@ -6,10 +6,11 @@ module Propellor.Property.Apt.PPA where
import Data.List
import Control.Applicative
import Prelude
-import Data.String.Utils
import Data.String (IsString(..))
+
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
+import Utility.Split
-- | Ensure software-properties-common is installed.
installed :: Property DebianLike
@@ -25,8 +26,8 @@ data PPA = PPA
, ppaArchive :: String -- ^ The name of the archive.
} deriving (Eq, Ord)
-instance Show PPA where
- show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p]
+instance ConfigurableValue PPA where
+ val p = concat ["ppa:", ppaAccount p, "/", ppaArchive p]
instance IsString PPA where
-- | Parse strings like "ppa:zfs-native/stable" into a PPA.
@@ -40,9 +41,9 @@ instance IsString PPA where
-- | Adds a PPA to the local system repositories.
addPpa :: PPA -> Property DebianLike
addPpa p =
- cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv
+ cmdPropertyEnv "apt-add-repository" ["--yes", val p] Apt.noninteractiveEnv
`assume` MadeChange
- `describe` ("Added PPA " ++ (show p))
+ `describe` ("Added PPA " ++ (val p))
`requires` installed
-- | A repository key ID to be downloaded with apt-key.
@@ -52,14 +53,11 @@ data AptKeyId = AptKeyId
, akiServer :: String
} deriving (Eq, Ord)
-instance Show AptKeyId where
- show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k]
-
-- | Adds an 'AptKeyId' from the specified GPG server.
addKeyId :: AptKeyId -> Property DebianLike
addKeyId keyId =
check keyTrusted akcmd
- `describe` (unwords ["Add third-party Apt key", show keyId])
+ `describe` (unwords ["Add third-party Apt key", desc keyId])
where
akcmd =
tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId]
@@ -72,10 +70,12 @@ addKeyId keyId =
nkid = take 8 (akiId keyId)
in
(isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"]
+ desc k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k]
-- | An Apt source line that apt-add-repository will just add to
--- sources.list. It's also an instance of both 'Show' and 'IsString' to make
--- using 'OverloadedStrings' in the configuration file easier.
+-- sources.list. It's also an instance of both 'ConfigurableValue'
+-- and 'IsString' to make using 'OverloadedStrings' in the configuration
+-- file easier.
--
-- | FIXME there's apparently an optional "options" fragment that I've
-- definitely not parsed here.
@@ -85,8 +85,8 @@ data AptSource = AptSource
, asComponents :: [String] -- ^ The list of components to install from this repository.
} deriving (Eq, Ord)
-instance Show AptSource where
- show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc]
+instance ConfigurableValue AptSource where
+ val asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc]
instance IsString AptSource where
fromString s =
@@ -103,7 +103,7 @@ addRepository :: AptRepository -> Property DebianLike
addRepository (AptRepositoryPPA p) = addPpa p
addRepository (AptRepositorySource src) =
check repoExists addSrc
- `describe` unwords ["Adding APT repository", show src]
+ `describe` unwords ["Adding APT repository", val src]
`requires` installed
where
allSourceLines =
@@ -112,4 +112,4 @@ addRepository (AptRepositorySource src) =
. filter (not . isPrefixOf "#")
. filter (/= "") . lines <$> allSourceLines
repoExists = isInfixOf [src] <$> activeSources
- addSrc = cmdProperty "apt-add-source" [show src]
+ addSrc = cmdProperty "apt-add-source" [val src]
diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs
index 4415f8c0..8ab5546b 100644
--- a/src/Propellor/Property/Attic.hs
+++ b/src/Propellor/Property/Attic.hs
@@ -1,8 +1,12 @@
-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
--
-- Support for the Attic backup tool <https://attic-backup.org/>
+--
+-- This module is deprecated because Attic is not available in debian
+-- stable any longer (so the installed property no longer works), and it
+-- appears to have been mostly supersceded by Borg.
-module Propellor.Property.Attic
+module Propellor.Property.Attic {-# DEPRECATED "Use Borg instead" #-}
( installed
, repoExists
, init
@@ -104,7 +108,7 @@ backup' dir backupdir crontimes extraargs kp = cronjob
where
desc = backupdir ++ " attic backup"
cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $
- "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd
+ "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd
lockfile = "/var/lock/propellor-attic.lock"
backupcmd = intercalate ";" $
createCommand
@@ -131,11 +135,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob
-- passed to the `backup` property, they will run attic prune to clean out
-- generations not specified here.
keepParam :: KeepPolicy -> AtticParam
-keepParam (KeepHours n) = "--keep-hourly=" ++ show n
-keepParam (KeepDays n) = "--keep-daily=" ++ show n
-keepParam (KeepWeeks n) = "--keep-daily=" ++ show n
-keepParam (KeepMonths n) = "--keep-monthly=" ++ show n
-keepParam (KeepYears n) = "--keep-yearly=" ++ show n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-daily=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
-- | Policy for backup generations to keep. For example, KeepDays 30 will
-- keep the latest backup for each day when a backup was made, and keep the
diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs
new file mode 100644
index 00000000..f0759dae
--- /dev/null
+++ b/src/Propellor/Property/Bootstrap.hs
@@ -0,0 +1,144 @@
+-- | This module contains properties that configure how Propellor
+-- bootstraps to run itself on a Host.
+
+module Propellor.Property.Bootstrap (
+ Bootstrapper(..),
+ Builder(..),
+ bootstrapWith,
+ RepoSource(..),
+ bootstrappedFrom,
+ clonedFrom
+) where
+
+import Propellor.Base
+import Propellor.Bootstrap
+import Propellor.Types.Info
+import Propellor.Property.Chroot
+
+import Data.List
+import qualified Data.ByteString as B
+
+-- | This property can be used to configure the `Bootstrapper` that is used
+-- to bootstrap propellor on a Host. For example, if you want to use
+-- stack:
+--
+-- > host "example.com" $ props
+-- > & bootstrapWith (Robustly Stack)
+--
+-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`,
+-- this property can also be added to the chroot to configure it.
+bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
+bootstrapWith b = pureInfoProperty desc (InfoVal b)
+ where
+ desc = "propellor bootstrapped with " ++ case b of
+ Robustly Stack -> "stack"
+ Robustly Cabal -> "cabal"
+ OSOnly -> "OS packages only"
+
+-- | Where a propellor repository should be bootstrapped from.
+data RepoSource
+ = GitRepoUrl String
+ | GitRepoOutsideChroot
+ -- ^ When used in a chroot, this copies the git repository from
+ -- outside the chroot, including its configuration.
+
+-- | Bootstraps a propellor installation into
+-- /usr/local/propellor/
+--
+-- Normally, propellor is bootstrapped by eg, using propellor --spin,
+-- and so this property is not generally needed.
+--
+-- This property only does anything when used inside a Chroot or other
+-- Container. 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 or stack.
+bootstrappedFrom :: RepoSource -> Property Linux
+bootstrappedFrom reposource = check inChroot $
+ go `requires` clonedFrom reposource
+ where
+ go :: Property Linux
+ go = property "Propellor bootstrapped" $ do
+ system <- getOS
+ bootstrapper <- getBootstrapper
+ assumeChange $ exposeTrueLocaldir $ const $
+ runShellCommand $ buildShellCommand
+ [ "cd " ++ localdir
+ , checkDepsCommand bootstrapper system
+ , buildCommand bootstrapper
+ ]
+
+-- | Clones the propellor repository into /usr/local/propellor/
+--
+-- If the propellor repo has already been cloned, pulls to get it
+-- up-to-date.
+clonedFrom :: RepoSource -> Property Linux
+clonedFrom reposource = case reposource of
+ GitRepoOutsideChroot -> go `onChange` copygitconfig
+ _ -> go
+ where
+ go :: Property Linux
+ go = property ("Propellor repo cloned from " ++ sourcedesc) $
+ ifM needclone (makeclone, updateclone)
+
+ makeclone = do
+ let tmpclone = localdir ++ ".tmpclone"
+ system <- getOS
+ assumeChange $ exposeTrueLocaldir $ \sysdir -> do
+ let originloc = case reposource of
+ GitRepoUrl s -> s
+ GitRepoOutsideChroot -> sysdir
+ runShellCommand $ buildShellCommand
+ [ installGitCommand system
+ , "rm -rf " ++ tmpclone
+ , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
+ , "mkdir -p " ++ localdir
+ -- This is done rather than deleting
+ -- the old localdir, because if it is bound
+ -- mounted from outside the chroot, deleting
+ -- it after unmounting in unshare will remove
+ -- the bind mount outside the unshare.
+ , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
+ , "rm -rf " ++ tmpclone
+ ]
+
+ updateclone = assumeChange $ exposeTrueLocaldir $ const $
+ runShellCommand $ buildShellCommand
+ [ "cd " ++ localdir
+ , "git pull"
+ ]
+
+ -- Copy the git config of the repo outside the chroot into the
+ -- chroot. This way it has the same remote urls, and other git
+ -- configuration.
+ copygitconfig :: Property Linux
+ copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do
+ let gitconfig = localdir </> ".git" </> "config"
+ cfg <- liftIO $ B.readFile gitconfig
+ exposeTrueLocaldir $ const $
+ liftIO $ B.writeFile gitconfig cfg
+ return MadeChange
+
+ needclone = (inChroot <&&> truelocaldirisempty)
+ <||> (liftIO (not <$> doesDirectoryExist localdir))
+
+ truelocaldirisempty = exposeTrueLocaldir $ const $
+ runShellCommand ("test ! -d " ++ localdir ++ "/.git")
+
+ sourcedesc = case reposource of
+ GitRepoUrl s -> s
+ GitRepoOutsideChroot -> localdir ++ " outside the chroot"
+
+assumeChange :: Propellor Bool -> Propellor Result
+assumeChange a = do
+ ok <- a
+ return (cmdResult ok <> MadeChange)
+
+buildShellCommand :: [String] -> String
+buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
+
+runShellCommand :: String -> Propellor Bool
+runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
index 16030562..ace7a48b 100644
--- a/src/Propellor/Property/Borg.hs
+++ b/src/Propellor/Property/Borg.hs
@@ -92,8 +92,8 @@ restored dir backupdir = go `requires` installed
-- > ["--exclude=/srv/git/tobeignored"]
-- > [Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1]
--
--- Note that this property does not make borg encrypt the backup
--- repository.
+-- Note that this property does not initialize the backup repository,
+-- so that will need to be done once, before-hand.
--
-- Since borg uses a fair amount of system resources, only one borg
-- backup job will be run at a time. Other jobs will wait their turns to
@@ -110,7 +110,7 @@ backup' dir backupdir crontimes extraargs kp = cronjob
where
desc = backupdir ++ " borg backup"
cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $
- "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd
+ "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd
lockfile = "/var/lock/propellor-borg.lock"
backupcmd = intercalate ";" $
createCommand
@@ -137,11 +137,11 @@ backup' dir backupdir crontimes extraargs kp = cronjob
-- passed to the `backup` property, they will run borg prune to clean out
-- generations not specified here.
keepParam :: KeepPolicy -> BorgParam
-keepParam (KeepHours n) = "--keep-hourly=" ++ show n
-keepParam (KeepDays n) = "--keep-daily=" ++ show n
-keepParam (KeepWeeks n) = "--keep-daily=" ++ show n
-keepParam (KeepMonths n) = "--keep-monthly=" ++ show n
-keepParam (KeepYears n) = "--keep-yearly=" ++ show n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-daily=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
-- | Policy for backup generations to keep. For example, KeepDays 30 will
-- keep the latest backup for each day when a backup was made, and keep the
diff --git a/src/Propellor/Property/Ccache.hs b/src/Propellor/Property/Ccache.hs
index c0b8d539..a2bef117 100644
--- a/src/Propellor/Property/Ccache.hs
+++ b/src/Propellor/Property/Ccache.hs
@@ -76,7 +76,7 @@ limitToParams NoLimit = []
limitToParams (MaxSize s) = case maxSizeParam s of
Just param -> [Right param]
Nothing -> [Left $ "unable to parse data size " ++ s]
-limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ show f]
+limitToParams (MaxFiles f) = [Right $ "--max-files=" ++ val f]
limitToParams (l1 :+ l2) = limitToParams l1 <> limitToParams l2
-- | Configures a ccache in /var/cache for a group
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index cb693a73..9e8bcd2f 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -4,12 +4,14 @@ module Propellor.Property.Chroot (
debootstrapped,
bootstrapped,
provisioned,
+ hostChroot,
Chroot(..),
ChrootBootstrapper(..),
Debootstrapped(..),
ChrootTarball(..),
noServices,
inChroot,
+ exposeTrueLocaldir,
-- * Internal use
provisioned',
propagateChrootInfo,
@@ -31,27 +33,28 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
import Utility.FileMode
+import Utility.Split
import qualified Data.Map as M
-import Data.List.Utils
import System.Posix.Directory
-import System.Console.Concurrent
-- | Specification of a chroot. Normally you'll use `debootstrapped` or
--- `bootstrapped` to construct a Chroot value.
+-- `bootstrapped` or `hostChroot` to construct a Chroot value.
data Chroot where
- Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
+ Chroot :: ChrootBootstrapper b => FilePath -> b -> InfoPropagator -> Host -> Chroot
instance IsContainer Chroot where
- containerProperties (Chroot _ _ h) = containerProperties h
- containerInfo (Chroot _ _ h) = containerInfo h
- setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
+ containerProperties (Chroot _ _ _ h) = containerProperties h
+ containerInfo (Chroot _ _ _ h) = containerInfo h
+ setContainerProperties (Chroot loc b p h) ps =
+ let h' = setContainerProperties h ps
+ in Chroot loc b p h'
chrootSystem :: Chroot -> Maybe System
chrootSystem = fromInfoVal . fromInfo . containerInfo
instance Show Chroot where
- show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
+ show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
@@ -93,6 +96,7 @@ instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
(Just s@(System (Debian _ _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
+ (Just (System ArchLinux _)) -> Left "Arch Linux not supported by debootstrap."
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; OS not specified"
where
@@ -114,7 +118,9 @@ debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
-bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
+bootstrapped bootstrapper location ps = c
+ where
+ c = Chroot location bootstrapper propagateChrootInfo (host location ps)
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -123,15 +129,14 @@ bootstrapped bootstrapper location ps = Chroot location bootstrapper (host locat
-- is first unmounted. Note that it does not ensure that any processes
-- that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
-provisioned c = provisioned' (propagateChrootInfo c) c False
+provisioned c = provisioned' c False
provisioned'
- :: (Property Linux -> Property (HasInfo + Linux))
- -> Chroot
+ :: Chroot
-> Bool
-> RevertableProperty (HasInfo + Linux) Linux
-provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
- (propigator $ setup `describe` chrootDesc c "exists")
+provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly =
+ (infopropigator c normalContainerInfo $ setup `describe` chrootDesc c "exists")
<!>
(teardown `describe` chrootDesc c "removed")
where
@@ -150,17 +155,20 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
- p `setInfoProperty` chrootInfo c
+type InfoPropagator = Chroot -> (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux)
+
+propagateChrootInfo :: InfoPropagator
+propagateChrootInfo c@(Chroot location _ _ _) pinfo p =
+ propagateContainer location c pinfo $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ h) = mempty `addInfo`
+chrootInfo (Chroot loc _ _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
-propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
+propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
shim <- liftIO $ ifM (doesDirectoryExist d)
@@ -192,14 +200,12 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr
, "--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
toChain :: HostName -> Chroot -> Bool -> IO CmdLine
-toChain parenthost (Chroot loc _ _) systemdonly = do
+toChain parenthost (Chroot loc _ _ _) systemdonly = do
onconsole <- isConsole <$> getMessageHandle
return $ ChrootChain parenthost loc systemdonly onconsole
@@ -214,17 +220,16 @@ 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 ())
-inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
+inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
mountproc
return (proc "chroot" (loc:cmd), cleanup)
where
@@ -244,13 +249,13 @@ provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
shimdir :: Chroot -> FilePath
-shimdir (Chroot loc _ _) = "chroot" </> mungeloc loc ++ ".shim"
+shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"
mungeloc :: FilePath -> String
mungeloc = replace "/" "_"
chrootDesc :: Chroot -> String -> String
-chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
+chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- | Adding this property to a chroot prevents daemons and other services
-- from being started, which is often something you want to prevent when
@@ -286,3 +291,54 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) }
newtype InChroot = InChroot Bool
deriving (Typeable, Show)
+
+-- | Runs an action with the true localdir exposed,
+-- not the one bind-mounted into a chroot. The action is passed the
+-- path containing the contents of the localdir outside the chroot.
+--
+-- In a chroot, this is accomplished by temporily bind mounting the localdir
+-- to a temp directory, to preserve access to the original bind mount. Then
+-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
+-- the temp directory is bind mounted back to the localdir.
+exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a
+exposeTrueLocaldir a = ifM inChroot
+ ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
+ bracket_
+ (movebindmount localdir tmpdir)
+ (movebindmount tmpdir localdir)
+ (a tmpdir)
+ , a localdir
+ )
+ where
+ movebindmount from to = liftIO $ do
+ run "mount" [Param "--bind", File from, File to]
+ -- Have to lazy unmount, because the propellor process
+ -- is running in the localdir that it's unmounting..
+ run "umount" [Param "-l", File from]
+ -- We were in the old localdir; move to the new one after
+ -- flipping the bind mounts. Otherwise, commands that try
+ -- to access the cwd will fail because it got umounted out
+ -- from under.
+ changeWorkingDirectory "/"
+ changeWorkingDirectory localdir
+ run cmd ps = unlessM (boolSystem cmd ps) $
+ error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
+
+-- | Generates a Chroot that has all the properties of a Host.
+--
+-- Note that it's possible to create loops using this, where a host
+-- contains a Chroot containing itself etc. Such loops will be detected at
+-- runtime.
+hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot
+hostChroot h bootstrapper d = chroot
+ where
+ chroot = Chroot d bootstrapper pinfo h
+ pinfo = propagateHostChrootInfo h
+
+-- This is different than propagateChrootInfo in that Info using
+-- HostContext is not made to use the name of the chroot as its context,
+-- but instead uses the hostname of the Host.
+propagateHostChrootInfo :: Host -> InfoPropagator
+propagateHostChrootInfo h c pinfo p =
+ propagateContainer (hostName h) c pinfo $
+ p `setInfoProperty` chrootInfo c
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 6b84acb5..f2de1a27 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -33,6 +33,7 @@ module Propellor.Property.Cmd (
Script,
scriptProperty,
userScriptProperty,
+ cmdResult,
-- * Lower-level interface for running commands
CommandParam(..),
boolSystem,
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index e69dc17d..e729d0cb 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -64,10 +64,13 @@ concurrently p1 p2 = (combineWith go go p1 p2)
-- Increase the number of capabilities right up to the number of
-- processors, so that A `concurrently` B `concurrently` C
-- runs all 3 properties on different processors when possible.
- go a1 a2 = do
+ go (Just a1) (Just a2) = Just $ do
n <- liftIO getNumProcessors
withCapabilities n $
concurrentSatisfy a1 a2
+ go (Just a1) Nothing = Just a1
+ go Nothing (Just a2) = Just a2
+ go Nothing Nothing = Nothing
-- | Ensures all the properties in the list, with a specified amount of
-- concurrency.
@@ -101,9 +104,9 @@ concurrentList getn d (Props ps) = property d go `addChildren` ps
Nothing -> return r
Just p -> do
hn <- asks hostName
- r' <- actionMessageOn hn
- (getDesc p)
- (getSatisfy p)
+ r' <- case getSatisfy p of
+ Nothing -> return NoChange
+ Just a -> actionMessageOn hn (getDesc p) a
worker q (r <> r')
-- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 8aa18d20..cfeb5aa7 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -323,15 +323,15 @@ instance Show NotConductorFor where
show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l)
instance IsInfo ConductorFor where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance IsInfo NotConductorFor where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
-- Added to Info when a host has been orchestrated.
newtype Orchestrated = Orchestrated Any
deriving (Typeable, Monoid, Show)
instance IsInfo Orchestrated where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
isOrchestrated :: Orchestrated -> Bool
isOrchestrated (Orchestrated v) = getAny v
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index b49c626e..76d52bd9 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -9,8 +9,10 @@ module Propellor.Property.ConfFile (
IniSection,
IniKey,
containsIniSetting,
+ lacksIniSetting,
hasIniSection,
lacksIniSection,
+ iniFileContains,
) where
import Propellor.Base
@@ -92,6 +94,19 @@ containsIniSetting f (header, key, value) = adjustIniSection
go (l:ls) = if isKeyVal l then confline : ls else l : go ls
isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]
+-- | Removes a key=value setting from a section of an .ini file.
+-- Note that the section heading is left in the file, so this is not a
+-- perfect reversion of containsIniSetting.
+lacksIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike
+lacksIniSetting f (header, key, value) = adjustIniSection
+ (f ++ " section [" ++ header ++ "] lacks " ++ key ++ "=" ++ value)
+ header
+ (filter (/= confline))
+ id
+ f
+ where
+ confline = key ++ "=" ++ value
+
-- | Ensures that a .ini file exists and contains a section
-- with a given key=value list of settings.
hasIniSection :: FilePath -> IniSection -> [(IniKey, String)] -> Property UnixLike
@@ -114,3 +129,13 @@ lacksIniSection f header = adjustIniSection
(const []) -- remove all lines of section
id -- add no lines if section is missing
f
+
+-- | Specifies the whole content of a .ini file.
+--
+-- Revertijg this causes the file not to exist.
+iniFileContains :: FilePath -> [(IniSection, [(IniKey, String)])] -> RevertableProperty UnixLike UnixLike
+iniFileContains f l = f `hasContent` content <!> notPresent f
+ where
+ content = concatMap sectioncontent l
+ sectioncontent (section, keyvalues) = iniHeader section :
+ map (\(key, value) -> key ++ "=" ++ value) keyvalues
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 0966a7e5..ab700a9d 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -80,7 +80,8 @@ niceJob desc times user cddir command = job desc times user cddir
-- | Installs a cron job to run propellor.
runPropellor :: Times -> Property UnixLike
-runPropellor times = withOS "propellor cron job" $ \w o ->
+runPropellor times = withOS "propellor cron job" $ \w o -> do
+ bootstrapper <- getBootstrapper
ensureProperty w $
niceJob "propellor" times (User "root") localdir
- (bootstrapPropellorCommand o ++ "; ./propellor")
+ (bootstrapPropellorCommand bootstrapper o ++ "; ./propellor")
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index d8a9c423..ad15f9a2 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -79,7 +79,7 @@ data DebianMirror = DebianMirror
mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror
mkDebianMirror dir crontimes = DebianMirror
- { _debianMirrorHostName = "httpredir.debian.org"
+ { _debianMirrorHostName = "deb.debian.org"
, _debianMirrorDir = dir
, _debianMirrorSuites = []
, _debianMirrorArchitectures = []
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index f8cb6e0e..e21bcdff 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -96,6 +96,7 @@ built' installprop target system@(System _ arch) config =
extractSuite :: System -> Maybe String
extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
+extractSuite (System (ArchLinux) _) = Nothing
extractSuite (System (FreeBSD _) _) = Nothing
-- | Ensures debootstrap is installed.
@@ -148,7 +149,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
. filter ("debootstrap_" `isInfixOf`)
. filter (".tar." `isInfixOf`)
. extractUrls baseurl <$>
- readFileStrictAnyEncoding indexfile
+ readFileStrict indexfile
nukeFile indexfile
tarfile <- case urls of
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 06dfa69c..6c1a572c 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -8,71 +8,95 @@ module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
-- * Properties
- DiskImage,
+ DiskImage(..),
+ RawDiskImage(..),
+ VirtualBoxPointer(..),
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
- -- * Finalization
- Finalization,
- grubBooted,
Grub.BIOS(..),
- noFinalization,
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
+import Propellor.Property.Mount
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Parted
-import Propellor.Property.Mount
import Propellor.Property.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
import Propellor.Container
import Utility.Path
+import Utility.FileMode
-import Data.List (isPrefixOf, isInfixOf, sortBy)
+import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4)
import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
-type DiskImage = FilePath
+-- | Type class of disk image formats.
+class DiskImage d where
+ -- | Get the location where the raw disk image should be stored.
+ rawDiskImage :: d -> RawDiskImage
+ -- | Describe the disk image (for display to the user)
+ describeDiskImage :: d -> String
+ -- | Convert the raw disk image file in the
+ -- `rawDiskImage` location into the desired disk image format.
+ -- For best efficiency, the raw disk imasge file should be left
+ -- unchanged on disk.
+ buildDiskImage :: d -> RevertableProperty DebianLike Linux
+
+-- | A raw disk image, that can be written directly out to a disk.
+newtype RawDiskImage = RawDiskImage FilePath
+
+instance DiskImage RawDiskImage where
+ rawDiskImage = id
+ describeDiskImage (RawDiskImage f) = f
+ buildDiskImage (RawDiskImage _) = doNothing <!> doNothing
+
+-- | A virtualbox .vmdk file, which contains a pointer to the raw disk
+-- image. This can be built very quickly.
+newtype VirtualBoxPointer = VirtualBoxPointer FilePath
+
+instance DiskImage VirtualBoxPointer where
+ rawDiskImage (VirtualBoxPointer f) = RawDiskImage $
+ dropExtension f ++ ".img"
+ describeDiskImage (VirtualBoxPointer f) = f
+ buildDiskImage (VirtualBoxPointer vmdkfile) = (setup <!> cleanup)
+ `describe` (vmdkfile ++ " built")
+ where
+ setup = cmdProperty "VBoxManage"
+ [ "internalcommands", "createrawvmdk"
+ , "-filename", vmdkfile
+ , "-rawdisk", diskimage
+ ]
+ `changesFile` vmdkfile
+ `onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes))
+ `requires` Apt.installed ["virtualbox"]
+ `requires` File.notPresent vmdkfile
+ cleanup = tightenTargets $ File.notPresent vmdkfile
+ RawDiskImage diskimage = rawDiskImage (VirtualBoxPointer vmdkfile)
-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
--
-- Then, the disk image is set up, and the chroot is copied into the
--- appropriate partition(s) of it.
---
--- Example use:
---
--- > import Propellor.Property.DiskImage
---
--- > let chroot d = Chroot.debootstrapped mempty d
--- > & osDebian Unstable X86_64
--- > & Apt.installed ["linux-image-amd64"]
--- > & User.hasPassword (User "root")
--- > & User.accountFor (User "demo")
--- > & User.hasPassword (User "demo")
--- > & User.hasDesktopGroups (User "demo")
--- > & ...
--- > in imageBuilt "/srv/images/foo.img" chroot
--- > MSDOS (grubBooted PC)
--- > [ partition EXT2 `mountedAt` "/boot"
--- > `setFlag` BootFlag
--- > , partition EXT4 `mountedAt` "/"
--- > `addFreeSpace` MegaBytes 100
--- > `mountOpt` errorReadonly
--- > , swapPartition (MegaBytes 256)
--- > ]
+-- appropriate partition(s) of it.
--
+-- The partitions default to being sized just large enough to fit the files
+-- from the chroot. You can use `addFreeSpace` to make them a bit larger
+-- than that, or `setSize` to use a fixed size.
+--
-- Note that the disk image file is reused if it already exists,
-- to avoid expensive IO to generate a new one. And, it's updated in-place,
-- so its contents are undefined during the build process.
@@ -81,39 +105,95 @@ type DiskImage = FilePath
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+--
+-- Example use:
+--
+-- > import Propellor.Property.DiskImage
+-- > import Propellor.Property.Chroot
+-- >
+-- > foo = host "foo.example.com" $ props
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot
+-- > MSDOS
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 100
+-- > `mountOpt` errorReadonly
+-- > , swapPartition (MegaBytes 256)
+-- > ]
+-- > where
+-- > mychroot d = debootstrapped mempty d $ props
+-- > & osDebian Unstable X86_64
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- > & User.hasPassword (User "root")
+-- > & User.accountFor (User "demo")
+-- > & User.hasPassword (User "demo")
+-- > & User.hasDesktopGroups (User "demo")
+-- > & ...
+--
+-- This can also be used with `Chroot.hostChroot` to build a disk image
+-- that has all the properties of a Host. For example:
+--
+-- > foo :: Host
+-- > foo = host "foo.example.com" $ props
+-- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img")
+-- > (hostChroot bar (Debootstrapped mempty))
+-- > MSDOS
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `addFreeSpace` MegaBytes 5000
+-- > , swapPartition (MegaBytes 256)
+-- > ]
+-- >
+-- > bar :: Host
+-- > bar = host "bar.example.com" $ props
+-- > & osDebian Unstable X86_64
+-- > & Apt.installed ["linux-image-amd64"]
+-- > & Grub.installed PC
+-- > & hasPassword (User "root")
+imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
+imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
-imageBuilt' rebuild img mkchroot tabletype final partspec =
+imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
+imageBuilt' rebuild img mkchroot tabletype partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
- desc = "built disk image " ++ img
+ desc = "built disk image " ++ describeDiskImage img
+ RawDiskImage imgfile = rawDiskImage img
cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
- chrootdir = img ++ ".chroot"
+ chrootdir = imgfile ++ ".chroot"
chroot =
- let c = mkchroot chrootdir
+ let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
-- Before ensuring any other properties of the chroot,
-- avoid starting services. Reverted by imageFinalized.
&^ Chroot.noServices
- -- First stage finalization.
- & fst final
& cachesCleaned
+ -- Only propagate privdata Info from this chroot, nothing else.
+ propprivdataonly (Chroot.Chroot d b ip h) =
+ Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h
+ -- Pick boot loader finalization based on which bootloader is
+ -- installed.
+ final = case fromInfo (containerInfo chroot) of
+ [GrubInstalled] -> grubBooted
+ [] -> unbootable "no bootloader is installed"
+ _ -> unbootable "multiple bootloaders are installed; don't know which to use"
-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
@@ -124,13 +204,14 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
skipit = doNothing :: Property UnixLike
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
+imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
- desc = img ++ " built from " ++ chrootdir
+ desc = describeDiskImage img ++ " built from " ++ chrootdir
+ dest@(RawDiskImage imgfile) = rawDiskImage img
mkimg = property' desc $ \w -> do
- -- unmount helper filesystems such as proc from the chroot
- -- before getting sizes
+ -- Unmount helper filesystems such as proc from the chroot
+ -- first; don't want to include the contents of those.
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
@@ -139,18 +220,20 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty w $
- imageExists img (partTableSize parttable)
+ imageExists' dest parttable
`before`
- partitioned YesReallyDeleteDiskContents img parttable
+ kpartx imgfile (mkimg' mnts mntopts parttable)
`before`
- kpartx img (mkimg' mnts mntopts parttable)
+ buildDiskImage img
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
imageFinalized final mnts mntopts devs parttable
- rmimg = File.notPresent img
+ rmimg = undoRevertableProperty (buildDiskImage img)
+ `before` undoRevertableProperty (imageExists' dest dummyparttable)
+ dummyparttable = PartTable tabletype []
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
mconcat $ zipWith3 (go w) mnts mntopts devs
where
@@ -179,10 +262,10 @@ partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
-- The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
-fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
+fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
where
- (mounts, mountopts, sizers) = unzip3 l
+ (mounts, mountopts, sizers, _) = unzip4 l
parttable = PartTable tt (zipWith id sizers basesizes)
-- | Generates a map of the sizes of the contents of
@@ -219,8 +302,8 @@ getMountSz szm l (Just mntpt) =
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- 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 :: RawDiskImage -> ByteSize -> Property Linux
+imageExists (RawDiskImage img) isz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
@@ -231,21 +314,47 @@ 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.
+-- | Ensure that disk image file exists and is partitioned.
--
--- The second property is run after the disk image is created,
--- with its populated partition tree mounted in the provided
--- location from the provided loop devices. This will typically
--- take care of installing the boot loader to the image.
+-- Avoids repartitioning the disk image, when a file of the right size
+-- already exists, and it has the same PartTable.
+imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
+imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc
+ where
+ desc = "disk image exists " ++ img
+ parttablefile = img ++ ".parttable"
+ setup = property' desc $ \w -> do
+ oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
+ res <- ensureProperty w $ imageExists dest (partTableSize parttable)
+ if res == NoChange && oldparttable == show parttable
+ then return NoChange
+ else if res == FailedChange
+ then return FailedChange
+ else do
+ liftIO $ writeFile parttablefile (show parttable)
+ ensureProperty w $ partitioned YesReallyDeleteDiskContents img parttable
+ cleanup = File.notPresent img
+ `before`
+ File.notPresent parttablefile
+
+-- | A property that is run after the disk image is created, with
+-- its populated partition tree mounted in the provided
+-- location from the provided loop devices. This is typically used to
+-- install a boot loader in the image's superblock.
--
--- It's ok if the second property leaves additional things mounted
+-- It's ok if the property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
+type Finalization = (FilePath -> [LoopDev] -> Property Linux)
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
+imageFinalized final mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
@@ -289,48 +398,27 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
-noFinalization :: Finalization
-noFinalization = (doNothing, \_ _ -> doNothing)
+unbootable :: String -> Finalization
+unbootable msg = \_ _ -> property desc $ do
+ warningMessage (desc ++ ": " ++ msg)
+ return FailedChange
+ where
+ desc = "image is not bootable"
-- | Makes grub be the boot loader of the disk image.
-grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (Grub.installed' bios, boots)
+--
+-- This does not install the grub package. You will need to add
+-- the `Grub.installed` property to the chroot.
+grubBooted :: Finalization
+grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
+ `describe` "disk image boots using grub"
where
- boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
- -- bind mount host /dev so grub can access the loop devices
- & bindMount "/dev" (inmnt "/dev")
- & mounted "proc" "proc" (inmnt "/proc") mempty
- & mounted "sysfs" "sys" (inmnt "/sys") mempty
- -- update the initramfs so it gets the uuid of the root partition
- & inchroot "update-initramfs" ["-u"]
- `assume` MadeChange
- -- work around for http://bugs.debian.org/802717
- & check haveosprober (inchroot "chmod" ["-x", osprober])
- & inchroot "update-grub" []
- `assume` MadeChange
- & check haveosprober (inchroot "chmod" ["+x", osprober])
- & inchroot "grub-install" [wholediskloopdev]
- `assume` MadeChange
- -- sync all buffered changes out to the disk image
- -- may not be necessary, but seemed needed sometimes
- -- when using the disk image right away.
- & cmdProperty "sync" []
- `assume` NoChange
- where
- -- cannot use </> since the filepath is absolute
- inmnt f = mnt ++ f
-
- inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
-
- haveosprober = doesFileExist (inmnt osprober)
- osprober = "/etc/grub.d/30_os-prober"
-
- -- It doesn't matter which loopdev we use; all
- -- come from the same disk image, and it's the loop dev
- -- for the whole disk image we seek.
- wholediskloopdev = case loopdevs of
- (l:_) -> wholeDiskLoopDev l
- [] -> error "No loop devs provided!"
+ -- It doesn't matter which loopdev we use; all
+ -- come from the same disk image, and it's the loop dev
+ -- for the whole disk image we seek.
+ wholediskloopdev = case loopdevs of
+ (l:_) -> wholeDiskLoopDev l
+ [] -> error "No loop devs provided!"
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 4b05df03..55249889 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -1,32 +1,28 @@
-- | Disk image partition specification and combinators.
+-- Partitions in disk images default to being sized large enough to hold
+-- the files that appear in the directory where the partition is to be
+-- mounted. Plus a fudge factor, since filesystems have some space
+-- overhead.
+
module Propellor.Property.DiskImage.PartSpec (
+ module Propellor.Types.PartSpec,
module Propellor.Property.DiskImage.PartSpec,
- Partition,
- PartSize(..),
- PartFlag(..),
- TableType(..),
- Fs(..),
- MountPoint,
+ module Propellor.Property.Parted.Types,
+ module Propellor.Property.Partition,
) where
import Propellor.Base
import Propellor.Property.Parted
-import Propellor.Property.Mount
+import Propellor.Types.PartSpec
+import Propellor.Property.Parted.Types
+import Propellor.Property.Partition (Fs(..))
--- | Specifies a mount point, mount options, and a constructor for a Partition.
---
--- The size that is eventually provided is the amount of space needed to
--- hold the files that appear in the directory where the partition is to be
--- mounted. Plus a fudge factor, since filesystems have some space
--- overhead.
-type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition)
-
--- | Partitions that are not to be mounted (ie, LinuxSwap), or that have
--- no corresponding directory in the chroot will have 128 MegaBytes
--- provided as a default size.
-defSz :: PartSize
-defSz = MegaBytes 128
+-- | Adds additional free space to the partition.
+addFreeSpace :: PartSpec t -> PartSize -> PartSpec t
+addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)
+ where
+ p' = \sz -> p (sz <> freesz)
-- | Add 2% for filesystem overhead. Rationalle for picking 2%:
-- A filesystem with 1% overhead might just sneak by as acceptable.
@@ -35,47 +31,3 @@ defSz = MegaBytes 128
-- Add an additional 200 mb for temp files, journals, etc.
fudge :: PartSize -> PartSize
fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
-
--- | Specifies a swap partition of a given size.
-swapPartition :: PartSize -> PartSpec
-swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz))
-
--- | Specifies a partition with a given filesystem.
---
--- The partition is not mounted anywhere by default; use the combinators
--- below to configure it.
-partition :: Fs -> PartSpec
-partition fs = (Nothing, mempty, mkPartition fs)
-
--- | Specifies where to mount a partition.
-mountedAt :: PartSpec -> FilePath -> PartSpec
-mountedAt (_, o, p) mp = (Just mp, o, p)
-
--- | Specifies a mount option, such as "noexec"
-mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec
-mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p)
-
--- | Mount option to make a partition be remounted readonly when there's an
--- error accessing it.
-errorReadonly :: MountOpts
-errorReadonly = toMountOpts "errors=remount-ro"
-
--- | Adds additional free space to the partition.
-addFreeSpace :: PartSpec -> PartSize -> PartSpec
-addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz))
-
--- | Forced a partition to be a specific size, instead of scaling to the
--- size needed for the files in the chroot.
-setSize :: PartSpec -> PartSize -> PartSpec
-setSize (mp, o, p) sz = (mp, o, const (p sz))
-
--- | Sets a flag on the partition.
-setFlag :: PartSpec -> PartFlag -> PartSpec
-setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
-
--- | Makes a MSDOS partition be Extended, rather than Primary.
-extended :: PartSpec -> PartSpec
-extended s = adjustp s $ \p -> p { partType = Extended }
-
-adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec
-adjustp (mp, o, p) f = (mp, o, f . p)
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 2e2710a6..889aece5 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -250,7 +250,7 @@ confStanza c =
cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"
ipblock name l =
[ "\t" ++ name ++ " {" ] ++
- (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++
+ (map (\ip -> "\t\t" ++ val ip ++ ";") l) ++
[ "\t};" ]
mastersblock
| null (confMasters c) = []
@@ -307,17 +307,17 @@ rValue :: Record -> Maybe String
rValue (Address (IPv4 addr)) = Just addr
rValue (Address (IPv6 addr)) = Just addr
rValue (CNAME d) = Just $ dValue d
-rValue (MX pri d) = Just $ show pri ++ " " ++ dValue d
+rValue (MX pri d) = Just $ val pri ++ " " ++ dValue d
rValue (NS d) = Just $ dValue d
rValue (SRV priority weight port target) = Just $ unwords
- [ show priority
- , show weight
- , show port
+ [ val priority
+ , val weight
+ , val port
, dValue target
]
rValue (SSHFP x y s) = Just $ unwords
- [ show x
- , show y
+ [ val x
+ , val y
, s
]
rValue (INCLUDE f) = Just f
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 2ef97438..66418253 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -55,21 +55,22 @@ import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
+import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
+import Utility.Split
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
import System.Posix.Process
import Prelude hiding (init)
import Data.List hiding (init)
-import Data.List.Utils
import qualified Data.Map as M
import System.Console.Concurrent
-installed :: Property DebianLike
-installed = Apt.installed ["docker.io"]
+installed :: Property (DebianLike + ArchLinux)
+installed = Apt.installed ["docker.io"] `pickOS` Pacman.installed ["docker"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
@@ -183,8 +184,9 @@ imagePulled ctr = pulled `describe` msg
image = getImageName ctr
propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
- p `addInfoProperty` dockerinfo
+propagateContainerInfo ctr@(Container _ h) p =
+ propagateContainer cn ctr normalContainerInfo $
+ p `addInfoProperty` dockerinfo
where
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
@@ -322,7 +324,7 @@ class Publishable p where
toPublish :: p -> String
instance Publishable (Bound Port) where
- toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p)
+ toPublish p = val (hostSide p) ++ ":" ++ val (containerSide p)
-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
instance Publishable String where
@@ -574,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
@@ -594,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 ]
@@ -659,10 +659,10 @@ listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property (HasInfo + Linux)
-runProp field val = tightenTargets $ pureInfoProperty (param) $
+runProp field v = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
- param = field++"="++val
+ param = field++"="++v
genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
genProp field mkval = tightenTargets $ pureInfoProperty field $
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 95fc6f81..3293599a 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
module Propellor.Property.File where
@@ -6,8 +6,10 @@ import Propellor.Base
import Utility.FileMode
import qualified Data.ByteString.Lazy as L
+import Data.List (isInfixOf, isPrefixOf)
import System.Posix.Files
import System.Exit
+import Data.Char
type Line = String
@@ -18,14 +20,42 @@ f `hasContent` newcontent = fileProperty
(\_oldcontent -> newcontent) f
-- | Ensures that a line is present in a file, adding it to the end if not.
+--
+-- For example:
+--
+-- > & "/etc/default/daemon.conf" `File.containsLine` ("cachesize = " ++ val 1024)
+--
+-- The above example uses `val` to serialize a `ConfigurableValue`
containsLine :: FilePath -> Line -> Property UnixLike
f `containsLine` l = f `containsLines` [l]
+-- | Ensures that a list of lines are present in a file, adding any that are not
+-- to the end of the file.
+--
+-- Note that this property does not guarantee that the lines will appear
+-- consecutively, nor in the order specified. If you need either of these, use
+-- 'File.containsBlock'.
containsLines :: FilePath -> [Line] -> Property UnixLike
f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
where
go content = content ++ filter (`notElem` content) ls
+-- | Ensures that a block of consecutive lines is present in a file, adding it
+-- to the end if not. Revert to ensure that the block is not present (though
+-- the lines it contains could be present, non-consecutively).
+containsBlock :: FilePath -> [Line] -> RevertableProperty UnixLike UnixLike
+f `containsBlock` ls =
+ fileProperty (f ++ " contains block:" ++ show ls) add f
+ <!> fileProperty (f ++ " lacks block:" ++ show ls) remove f
+ where
+ add content
+ | ls `isInfixOf` content = content
+ | otherwise = content ++ ls
+ remove [] = []
+ remove content@(x:xs)
+ | ls `isPrefixOf` content = remove (drop (length ls) content)
+ | otherwise = x : remove xs
+
-- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
@@ -75,11 +105,11 @@ hasPrivContent' writemode source f context =
-- | Replaces the content of a file with the transformed content of another file
basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
-f `basedOn` (f', a) = property' desc $ \o -> do
- tmpl <- liftIO $ readFile f'
+f `basedOn` (src, a) = property' desc $ \o -> do
+ tmpl <- liftIO $ readFile src
ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
- desc = f ++ " is based on " ++ f'
+ desc = f ++ " is based on " ++ src
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property UnixLike
@@ -120,23 +150,26 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
-- | Ensures that a file is a copy of another (regular) file.
isCopyOf :: FilePath -> FilePath -> Property UnixLike
-f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
+f `isCopyOf` src = property desc $ go =<< (liftIO $ tryIO $ getFileStatus src)
where
- desc = f ++ " is copy of " ++ f'
+ desc = f ++ " is copy of " ++ src
go (Right stat) = if isRegularFile stat
- then gocmp =<< (liftIO $ cmp)
- else warningMessage (f' ++ " is not a regular file") >>
+ then ifM (liftIO $ doesFileExist f)
+ ( gocmp =<< (liftIO $ cmp)
+ , doit
+ )
+ else warningMessage (src ++ " is not a regular file") >>
return FailedChange
go (Left e) = warningMessage (show e) >> return FailedChange
- cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f']
+ cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File src]
gocmp ExitSuccess = noChange
gocmp (ExitFailure 1) = doit
gocmp _ = warningMessage "cmp failed" >> return FailedChange
- doit = makeChange $ copy f' `viaStableTmp` f
- copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed"
- runcp src dest = boolSystem "cp"
+ doit = makeChange $ copy `viaStableTmp` f
+ copy dest = unlessM (runcp dest) $ errorMessage "cp failed"
+ runcp dest = boolSystem "cp"
[Param "--preserve=all", Param "--", File src, File dest]
-- | Ensures that a file/dir has the specified owner and group.
@@ -147,6 +180,20 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
`changesFile` f
og = owner ++ ":" ++ group
+-- | Given a base directory, and a relative path under that
+-- directory, applies a property to each component of the path in turn,
+-- starting with the base directory.
+--
+-- For example, to make a file owned by a user, making sure their home
+-- directory and the subdirectories to it are also owned by them:
+--
+-- > "/home/user/program/file" `hasContent` ["foo"]
+-- > `before` applyPath "/home/user" ".config/program/file"
+-- > (\f -> ownerGroup f (User "user") (Group "user"))
+applyPath :: Monoid (Property metatypes) => FilePath -> FilePath -> (FilePath -> Property metatypes) -> Property metatypes
+applyPath basedir relpath mkp = mconcat $
+ map mkp (scanl (</>) basedir (splitPath relpath))
+
-- | Ensures that a file/dir has the specfied mode.
mode :: FilePath -> FileMode -> Property UnixLike
mode f v = p `changesFile` f
@@ -221,3 +268,51 @@ viaStableTmp a f = bracketIO setup cleanup go
go tmpfile = do
a tmpfile
liftIO $ rename tmpfile f
+
+-- | Generates a base configuration file name from a String, which
+-- can be put in a configuration directory, such as
+-- </etc/apt/sources.list.d/>
+--
+-- The generated file name is limited to using ASCII alphanumerics,
+-- \'_\' and \'.\' , so that programs that only accept a limited set of
+-- characters will accept it. Any other characters will be encoded
+-- in escaped form.
+--
+-- Some file extensions, such as ".old" may be filtered out by
+-- programs that use configuration directories. To avoid such problems,
+-- it's a good idea to add an static prefix and extension to the
+-- result of this function. For example:
+--
+-- > aptConf foo = "/etc/apt/apt.conf.d" </> "propellor_" ++ configFileName foo <.> ".conf"
+configFileName :: String -> FilePath
+configFileName = concatMap escape
+ where
+ escape c
+ | isAscii c && isAlphaNum c = [c]
+ | c == '.' = [c]
+ | otherwise = '_' : show (ord c)
+
+-- | Applies configFileName to any value that can be shown.
+showConfigFileName :: Show v => v -> FilePath
+showConfigFileName = configFileName . show
+
+-- | Inverse of showConfigFileName.
+readConfigFileName :: Read v => FilePath -> Maybe v
+readConfigFileName = readish . unescape
+ where
+ unescape [] = []
+ unescape ('_':cs) = case break (not . isDigit) cs of
+ ([], _) -> '_' : unescape cs
+ (ns, cs') -> case readish ns of
+ Nothing -> '_' : ns ++ unescape cs'
+ Just n -> chr n : unescape cs'
+ unescape (c:cs) = c : unescape cs
+
+data Overwrite = OverwriteExisting | PreserveExisting
+
+-- | When passed PreserveExisting, only ensures the property when the file
+-- does not exist.
+checkOverwrite :: Overwrite -> FilePath -> (FilePath -> Property i) -> Property i
+checkOverwrite OverwriteExisting f mkp = mkp f
+checkOverwrite PreserveExisting f mkp =
+ check (not <$> doesFileExist f) (mkp f)
diff --git a/src/Propellor/Property/Firejail.hs b/src/Propellor/Property/Firejail.hs
index b7841e07..6e877683 100644
--- a/src/Propellor/Property/Firejail.hs
+++ b/src/Propellor/Property/Firejail.hs
@@ -22,7 +22,7 @@ installed = Apt.installed ["firejail"]
--
-- See "DESKTOP INTEGRATION" in firejail(1).
jailed :: [String] -> Property DebianLike
-jailed ps = (jailed' `applyToList` ps)
+jailed ps = mconcat (map jailed' ps)
`requires` installed
`describe` unwords ("firejail jailed":ps)
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index 3ea19ffa..736a4458 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -15,7 +15,6 @@ module Propellor.Property.Firewall (
TCPFlag(..),
Frequency(..),
IPWithMask(..),
- fromIPWithMask
) where
import Data.Monoid
@@ -44,16 +43,16 @@ rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
toIpTable :: Rule -> [CommandParam]
toIpTable r = map Param $
- fromChain (ruleChain r) :
+ val (ruleChain r) :
toIpTableArg (ruleRules r) ++
- ["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)]
+ ["-t", val (ruleTable r), "-j", val (ruleTarget r)]
toIpTableArg :: Rules -> [String]
toIpTableArg Everything = []
toIpTableArg (Proto proto) = ["-p", map toLower $ show proto]
-toIpTableArg (DPort port) = ["--dport", fromPort port]
+toIpTableArg (DPort port) = ["--dport", val port]
toIpTableArg (DPortRange (portf, portt)) =
- ["--dport", fromPort portf ++ ":" ++ fromPort portt]
+ ["--dport", val portf ++ ":" ++ val portt]
toIpTableArg (InIFace iface) = ["-i", iface]
toIpTableArg (OutIFace iface) = ["-o", iface]
toIpTableArg (Ctstate states) =
@@ -64,12 +63,12 @@ toIpTableArg (Ctstate states) =
toIpTableArg (ICMPType i) =
[ "-m"
, "icmp"
- , "--icmp-type", fromICMPTypeMatch i
+ , "--icmp-type", val i
]
toIpTableArg (RateLimit f) =
[ "-m"
, "limit"
- , "--limit", fromFrequency f
+ , "--limit", val f
]
toIpTableArg (TCPFlags m c) =
[ "-m"
@@ -87,30 +86,30 @@ toIpTableArg (GroupOwner (Group g)) =
]
toIpTableArg (Source ipwm) =
[ "-s"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (Destination ipwm) =
[ "-d"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (NotDestination ipwm) =
[ "!"
, "-d"
- , intercalate "," (map fromIPWithMask ipwm)
+ , intercalate "," (map val ipwm)
]
toIpTableArg (NatDestination ip mport) =
[ "--to-destination"
- , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort p) mport
+ , val ip ++ maybe "" (\p -> ":" ++ val p) mport
]
toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r'
data IPWithMask = IPWithNoMask IPAddr | IPWithIPMask IPAddr IPAddr | IPWithNumMask IPAddr Int
deriving (Eq, Show)
-fromIPWithMask :: IPWithMask -> String
-fromIPWithMask (IPWithNoMask ip) = fromIPAddr ip
-fromIPWithMask (IPWithIPMask ip ipm) = fromIPAddr ip ++ "/" ++ fromIPAddr ipm
-fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m
+instance ConfigurableValue IPWithMask where
+ val (IPWithNoMask ip) = val ip
+ val (IPWithIPMask ip ipm) = val ip ++ "/" ++ val ipm
+ val (IPWithNumMask ip m) = val ip ++ "/" ++ val m
data Rule = Rule
{ ruleChain :: Chain
@@ -122,33 +121,33 @@ data Rule = Rule
data Table = Filter | Nat | Mangle | Raw | Security
deriving (Eq, Show)
-fromTable :: Table -> String
-fromTable Filter = "filter"
-fromTable Nat = "nat"
-fromTable Mangle = "mangle"
-fromTable Raw = "raw"
-fromTable Security = "security"
+instance ConfigurableValue Table where
+ val Filter = "filter"
+ val Nat = "nat"
+ val Mangle = "mangle"
+ val Raw = "raw"
+ val Security = "security"
data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String
deriving (Eq, Show)
-fromTarget :: Target -> String
-fromTarget ACCEPT = "ACCEPT"
-fromTarget REJECT = "REJECT"
-fromTarget DROP = "DROP"
-fromTarget LOG = "LOG"
-fromTarget (TargetCustom t) = t
+instance ConfigurableValue Target where
+ val ACCEPT = "ACCEPT"
+ val REJECT = "REJECT"
+ val DROP = "DROP"
+ val LOG = "LOG"
+ val (TargetCustom t) = t
data Chain = INPUT | OUTPUT | FORWARD | PREROUTING | POSTROUTING | ChainCustom String
deriving (Eq, Show)
-fromChain :: Chain -> String
-fromChain INPUT = "INPUT"
-fromChain OUTPUT = "OUTPUT"
-fromChain FORWARD = "FORWARD"
-fromChain PREROUTING = "PREROUTING"
-fromChain POSTROUTING = "POSTROUTING"
-fromChain (ChainCustom c) = c
+instance ConfigurableValue Chain where
+ val INPUT = "INPUT"
+ val OUTPUT = "OUTPUT"
+ val FORWARD = "FORWARD"
+ val PREROUTING = "PREROUTING"
+ val POSTROUTING = "POSTROUTING"
+ val (ChainCustom c) = c
data Proto = TCP | UDP | ICMP
deriving (Eq, Show)
@@ -159,15 +158,15 @@ data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID
data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int
deriving (Eq, Show)
-fromICMPTypeMatch :: ICMPTypeMatch -> String
-fromICMPTypeMatch (ICMPTypeName t) = t
-fromICMPTypeMatch (ICMPTypeCode c) = show c
+instance ConfigurableValue ICMPTypeMatch where
+ val (ICMPTypeName t) = t
+ val (ICMPTypeCode c) = val c
data Frequency = NumBySecond Int
deriving (Eq, Show)
-fromFrequency :: Frequency -> String
-fromFrequency (NumBySecond n) = show n ++ "/second"
+instance ConfigurableValue Frequency where
+ val (NumBySecond n) = val n ++ "/second"
type TCPFlagMask = [TCPFlag]
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 704c1db9..77bf5768 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -39,7 +39,7 @@ pkgCmd cmd args =
newtype PkgUpdate = PkgUpdate String
deriving (Typeable, Monoid, Show)
instance IsInfo PkgUpdate where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
pkgUpdated :: PkgUpdate -> Bool
pkgUpdated (PkgUpdate _) = True
@@ -55,8 +55,9 @@ update =
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
+
instance IsInfo PkgUpgrade where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
pkgUpgraded :: PkgUpgrade -> Bool
pkgUpgraded (PkgUpgrade _) = True
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index 58477468..378c5530 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -19,8 +19,9 @@ poudriereConfigPath = "/usr/local/etc/poudriere.conf"
newtype PoudriereConfigured = PoudriereConfigured String
deriving (Typeable, Monoid, Show)
+
instance IsInfo PoudriereConfigured where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
@@ -68,7 +69,7 @@ jail j@(Jail name version arch) = tightenTargets $
nx <- liftIO $ not <$> jailExists j
return $ c && nx
- (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", show arch, "-v", show version]
+ (cmd, args) = poudriereCommand "jail" ["-c", "-j", name, "-a", val arch, "-v", val version]
createJail = cmdProperty cmd args
in
check chk createJail
@@ -101,9 +102,10 @@ data PoudriereZFS = PoudriereZFS ZFS.ZFS ZFS.ZFSProperties
data Jail = Jail String FBSDVersion PoudriereArch
data PoudriereArch = I386 | AMD64 deriving (Eq)
-instance Show PoudriereArch where
- show I386 = "i386"
- show AMD64 = "amd64"
+
+instance ConfigurableValue PoudriereArch where
+ val I386 = "i386"
+ val AMD64 = "amd64"
fromArchitecture :: Architecture -> PoudriereArch
fromArchitecture X86_64 = AMD64
@@ -127,7 +129,7 @@ instance ToShellConfigLines PoudriereZFS where
toAssoc (PoudriereZFS (ZFS.ZFS (ZFS.ZPool pool) dataset) _) =
[ ("NO_ZFS", "no")
, ("ZPOOL", pool)
- , ("ZROOTFS", show dataset)
+ , ("ZROOTFS", val dataset)
]
type ConfigLine = String
diff --git a/src/Propellor/Property/FreeDesktop.hs b/src/Propellor/Property/FreeDesktop.hs
new file mode 100644
index 00000000..75dcbdfa
--- /dev/null
+++ b/src/Propellor/Property/FreeDesktop.hs
@@ -0,0 +1,29 @@
+-- | Freedesktop.org configuration file properties.
+
+module Propellor.Property.FreeDesktop where
+
+import Propellor.Base
+import Propellor.Property.ConfFile
+
+desktopFile :: String -> FilePath
+desktopFile s = s ++ ".desktop"
+
+-- | Name used in a desktop file; user visible.
+type Name = String
+
+-- | Command that a dekstop file runs. May include parameters.
+type Exec = String
+
+-- | Specifies an autostart file. By default it will be located in the
+-- system-wide autostart directory.
+autostart :: FilePath -> Name -> Exec -> RevertableProperty UnixLike UnixLike
+autostart f n e = ("/etc/xdg/autostart" </> f) `iniFileContains`
+ [ ("Desktop Entry",
+ [ ("Type", "Application")
+ , ("Version", "1.0")
+ , ("Name", n)
+ , ("Comment", "Autostart")
+ , ("Terminal", "False")
+ , ("Exec", e)
+ ] )
+ ]
diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs
index 60f11d8e..29b85426 100644
--- a/src/Propellor/Property/Fstab.hs
+++ b/src/Propellor/Property/Fstab.hs
@@ -24,19 +24,32 @@ import Utility.Table
-- Note that if anything else is already mounted at the `MountPoint`, it
-- will be left as-is by this property.
mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux
-mounted fs src mnt opts = tightenTargets $
- "/etc/fstab" `File.containsLine` l
- `describe` (mnt ++ " mounted by fstab")
+mounted fs src mnt opts = tightenTargets $
+ listed fs src mnt opts
`onChange` mountnow
where
- l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno]
- dump = "0"
- passno = "2"
-- This use of mountPoints, which is linux-only, is why this
-- property currently only supports linux.
mountnow = check (notElem mnt <$> mountPoints) $
cmdProperty "mount" [mnt]
+-- | Ensures that </etc/fstab> contains a line mounting the specified
+-- `Source` on the specified `MountPoint`. Does not ensure that it's
+-- currently `mounted`.
+listed :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
+listed fs src mnt opts = "/etc/fstab" `File.containsLine` l
+ `describe` (mnt ++ " mounted by fstab")
+ where
+ l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno]
+ dump = "0"
+ passno = "2"
+
+-- | Ensures that </etc/fstab> contains a line enabling the specified
+-- `Source` to be used as swap space, and that it's enabled.
+swap :: Source -> Property Linux
+swap src = listed "swap" src "none" mempty
+ `onChange` swapOn src
+
newtype SwapPartition = SwapPartition FilePath
-- | Replaces </etc/fstab> with a file that should cause the currently
@@ -77,8 +90,8 @@ genFstab mnts swaps mnttransform = do
, pure "0"
, pure (if mnt == "/" then "1" else "2")
]
- getswapcfg (SwapPartition swap) = sequence
- [ fromMaybe swap <$> getM (\a -> a swap)
+ getswapcfg (SwapPartition s) = sequence
+ [ fromMaybe s <$> getM (\a -> a s)
[ uuidprefix getSourceUUID
, sourceprefix getSourceLabel
]
diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs
index 74e9df5a..27baa4ba 100644
--- a/src/Propellor/Property/Gpg.hs
+++ b/src/Propellor/Property/Gpg.hs
@@ -2,7 +2,6 @@ module Propellor.Property.Gpg where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
-import Utility.FileSystemEncoding
import System.PosixCompat
@@ -35,7 +34,6 @@ keyImported key@(GpgKeyId keyid) user@(User u) = prop
( return NoChange
, makeChange $ withHandle StdinHandle createProcessSuccess
(proc "su" ["-c", "gpg --import", u]) $ \h -> do
- fileEncoding h
hPutStr h (unlines keylines)
hClose h
)
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index a03fc5a0..d0516dc8 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -3,6 +3,10 @@ module Propellor.Property.Grub where
import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
+import Propellor.Property.Mount
+import Propellor.Property.Chroot (inChroot)
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
-- | Eg, \"hd0,0\" or \"xen/xvda1\"
type GrubDevice = String
@@ -18,9 +22,10 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- | Installs the grub package. This does not make grub be used as the
-- bootloader.
--
--- This includes running update-grub.
-installed :: BIOS -> Property DebianLike
-installed bios = installed' bios `onChange` mkConfig
+-- This includes running update-grub, unless it's run in a chroot.
+installed :: BIOS -> Property (HasInfo + DebianLike)
+installed bios = installed' bios
+ `onChange` (check (not <$> inChroot) mkConfig)
-- Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
@@ -29,11 +34,11 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property Linux
-installed' bios = (aptinstall `pickOS` unsupportedOS)
+installed' :: BIOS -> Property (HasInfo + DebianLike)
+installed' bios = setInfoProperty aptinstall
+ (toInfo [GrubInstalled])
`describe` "grub package installed"
where
- aptinstall :: Property DebianLike
aptinstall = Apt.installed [debpkg]
debpkg = case bios of
PC -> "grub-pc"
@@ -64,12 +69,12 @@ boots dev = tightenTargets $ cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
& File.dirExists "/boot/grub"
& "/boot/grub/menu.lst" `File.hasContent`
[ "default 1"
- , "timeout " ++ show timeout
+ , "timeout " ++ val timeout
, ""
, "title grub-xen shim"
, "root (" ++ rootdev ++ ")"
@@ -85,3 +90,54 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
`assume` MadeChange
`describe` "/boot-xen-shim"
+
+-- | This is a version of `boots` that makes grub boot the system mounted
+-- at a particular directory. The OSDevice should be the underlying disk
+-- device that grub will be installed to (generally a whole disk,
+-- not a partition).
+bootsMounted :: FilePath -> OSDevice -> Property Linux
+bootsMounted mnt wholediskdev = combineProperties desc $ props
+ -- remove mounts that are done below to make sure the right thing
+ -- gets mounted
+ & cleanupmounts
+ -- bind mount host /dev so grub can access the loop devices
+ & bindMount "/dev" (inmnt "/dev")
+ & mounted "proc" "proc" (inmnt "/proc") mempty
+ & mounted "sysfs" "sys" (inmnt "/sys") mempty
+ -- update the initramfs so it gets the uuid of the root partition
+ & inchroot "update-initramfs" ["-u"]
+ `assume` MadeChange
+ -- work around for http://bugs.debian.org/802717
+ & check haveosprober (inchroot "chmod" ["-x", osprober])
+ & inchroot "update-grub" []
+ `assume` MadeChange
+ & check haveosprober (inchroot "chmod" ["+x", osprober])
+ & inchroot "grub-install" [wholediskdev]
+ `assume` MadeChange
+ & cleanupmounts
+ -- sync all buffered changes out to the disk in case it's
+ -- used right away
+ & cmdProperty "sync" []
+ `assume` NoChange
+ where
+ desc = "grub boots " ++ wholediskdev
+
+ -- cannot use </> since the filepath is absolute
+ inmnt f = mnt ++ f
+
+ inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+ haveosprober = doesFileExist (inmnt osprober)
+ osprober = "/etc/grub.d/30_os-prober"
+
+ cleanupmounts :: Property Linux
+ cleanupmounts = property desc $ liftIO $ do
+ cleanup "/sys"
+ cleanup "/proc"
+ cleanup "/dev"
+ return NoChange
+ where
+ cleanup m =
+ let mp = inmnt m
+ in whenM (isMounted mp) $
+ umountLazy mp
diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs
index fca3df63..ebe8d261 100644
--- a/src/Propellor/Property/HostingProvider/Linode.hs
+++ b/src/Propellor/Property/HostingProvider/Linode.hs
@@ -8,7 +8,7 @@ import Utility.FileMode
-- | Configures grub to use the serial console as set up by Linode.
-- Useful when running a distribution supplied kernel.
-- <https://www.linode.com/docs/tools-reference/custom-kernels-distros/run-a-distribution-supplied-kernel-with-kvm>
-serialGrub :: Property DebianLike
+serialGrub :: Property (HasInfo + DebianLike)
serialGrub = "/etc/default/grub" `File.containsLines`
[ "GRUB_CMDLINE_LINUX=\"console=ttyS0,19200n8\""
, "GRUB_DISABLE_LINUX_UUID=true"
@@ -17,11 +17,12 @@ serialGrub = "/etc/default/grub" `File.containsLines`
]
`onChange` Grub.mkConfig
`requires` Grub.installed Grub.PC
+ `describe` "GRUB configured for Linode serial console"
-- | Linode's pv-grub-x86_64 (only used for its older XEN instances)
-- does not support booting recent Debian kernels compressed
-- with xz. This sets up pv-grub chaining to enable it.
-chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike
+chainPVGrub :: Grub.TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"
-- | Linode disables mlocate's cron job's execute permissions,
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index e1342d91..1eb9d690 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -3,9 +3,9 @@ module Propellor.Property.Hostname where
import Propellor.Base
import qualified Propellor.Property.File as File
import Propellor.Property.Chroot (inChroot)
+import Utility.Split
import Data.List
-import Data.List.Utils
-- | Ensures that the hostname is set using best practices, to whatever
-- name the `Host` has.
diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs
index 339fa9a3..d471d314 100644
--- a/src/Propellor/Property/LightDM.hs
+++ b/src/Propellor/Property/LightDM.hs
@@ -10,7 +10,12 @@ installed :: Property DebianLike
installed = Apt.installed ["lightdm"]
-- | Configures LightDM to skip the login screen and autologin as a user.
-autoLogin :: User -> Property UnixLike
-autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting`
- ("SeatDefaults", "autologin-user", u)
- `describe` "lightdm autologin"
+autoLogin :: User -> RevertableProperty DebianLike DebianLike
+autoLogin (User u) = (setup <!> cleanup)
+ `describe` ("lightdm autologin for " ++ u)
+ where
+ cf = "/etc/lightdm/lightdm.conf"
+ setting = ("Seat:*", "autologin-user", u)
+ setup = cf `ConfFile.containsIniSetting` setting
+ `requires` installed
+ cleanup = tightenTargets $ cf `ConfFile.lacksIniSetting` setting
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 0eec04c7..758e51ce 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -43,6 +43,13 @@ propertyList desc (Props ps) =
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn. Stops if a property fails.
+--
+-- > combineProperties "foo" $ props
+-- > & bar
+-- > & baz
+--
+-- This is similar to using `mconcat` with a list of properties,
+-- except it can combine together different types of properties.
combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties desc (Props ps) =
property desc (combineSatisfy cs NoChange)
@@ -53,7 +60,7 @@ combineProperties desc (Props ps) =
combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
combineSatisfy (p:ps) rs = do
- r <- catchPropellor $ getSatisfy p
+ r <- maybe (return NoChange) catchPropellor (getSatisfy p)
case r of
FailedChange -> return FailedChange
_ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs
index b7cf242c..53091fc9 100644
--- a/src/Propellor/Property/Locale.hs
+++ b/src/Propellor/Property/Locale.hs
@@ -4,6 +4,7 @@ module Propellor.Property.Locale where
import Propellor.Base
import Propellor.Property.File
+import qualified Propellor.Property.Apt as Apt
import Data.List (isPrefixOf)
@@ -50,7 +51,8 @@ locale `isSelectedFor` vars = do
-- Per Debian bug #684134 we cannot ensure a locale is generated by means of
-- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually.
available :: Locale -> RevertableProperty DebianLike DebianLike
-available locale = ensureAvailable <!> ensureUnavailable
+available locale = ensureAvailable `requires` Apt.installed ["locales"]
+ <!> ensureUnavailable
where
f = "/etc/locale.gen"
desc = (locale ++ " locale generated")
@@ -61,7 +63,7 @@ available locale = ensureAvailable <!> ensureUnavailable
then ensureProperty w $
fileProperty desc (foldr uncomment []) f
`onChange` regenerate
- else return FailedChange -- locale unavailable for generation
+ else error $ "locale " ++ locale ++ " is not present in /etc/locale.gen, even in commented out form; cannot generate"
ensureUnavailable :: Property DebianLike
ensureUnavailable = tightenTargets $
fileProperty (locale ++ " locale not generated") (foldr comment []) f
diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs
index ced9fce2..8eaf56fd 100644
--- a/src/Propellor/Property/Logcheck.hs
+++ b/src/Propellor/Property/Logcheck.hs
@@ -16,21 +16,21 @@ import qualified Propellor.Property.File as File
data ReportLevel = Workstation | Server | Paranoid
type Service = String
-instance Show ReportLevel where
- show Workstation = "workstation"
- show Server = "server"
- show Paranoid = "paranoid"
+instance ConfigurableValue ReportLevel where
+ val Workstation = "workstation"
+ val Server = "server"
+ val Paranoid = "paranoid"
-- The common prefix used by default in syslog lines.
defaultPrefix :: String
defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ "
ignoreFilePath :: ReportLevel -> Service -> FilePath
-ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n
+ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (val t) </> n
ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike
ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls
- `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")")
+ `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ val t ++ ")")
installed :: Property DebianLike
installed = Apt.installed ["logcheck"]
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 026509a9..2c4d9620 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -40,6 +40,9 @@ formatMountOpts (MountOpts []) = "defaults"
formatMountOpts (MountOpts l) = intercalate "," l
-- | Mounts a device, without listing it in </etc/fstab>.
+--
+-- Note that this property will fail if the device is already mounted
+-- at the MountPoint.
mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted fs src mnt opts = property (mnt ++ " mounted") $
toResult <$> liftIO (mount fs src mnt opts)
@@ -52,6 +55,17 @@ bindMount src dest = tightenTargets $
`assume` MadeChange
`describe` ("bind mounted " ++ src ++ " to " ++ dest)
+-- | Enables swapping to a device, which must be formatted already as a swap
+-- partition.
+swapOn :: Source -> RevertableProperty Linux Linux
+swapOn mnt = tightenTargets doswapon <!> tightenTargets doswapoff
+ where
+ swaps = lines <$> readProcess "swapon" ["--show=NAME"]
+ doswapon = check (notElem mnt <$> swaps) $
+ cmdProperty "swapon" [mnt]
+ doswapoff = check (elem mnt <$> swaps) $
+ cmdProperty "swapoff" [mnt]
+
mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount fs src mnt opts = boolSystem "mount" $
[ Param "-t", Param fs
@@ -64,6 +78,10 @@ mount fs src mnt opts = boolSystem "mount" $
mountPoints :: IO [MountPoint]
mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
+-- | Checks if anything is mounted at the MountPoint.
+isMounted :: MountPoint -> IO Bool
+isMounted mnt = isJust <$> getFsType mnt
+
-- | Finds all filesystems mounted inside the specified directory.
mountPointsBelow :: FilePath -> IO [MountPoint]
mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
@@ -115,12 +133,15 @@ blkidTag tag dev = catchDefaultIO Nothing $
-- | Unmounts a device or mountpoint,
-- lazily so any running processes don't block it.
+--
+-- Note that this will fail if it's not mounted.
umountLazy :: FilePath -> IO ()
umountLazy mnt =
unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
stopPropellorMessage $ "failed unmounting " ++ mnt
--- | Unmounts anything mounted inside the specified directory.
+-- | Unmounts anything mounted inside the specified directory,
+-- not including the directory itself.
unmountBelow :: FilePath -> IO ()
unmountBelow d = do
submnts <- mountPointsBelow d
diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs
index dd74d91b..6dab25ef 100644
--- a/src/Propellor/Property/Munin.hs
+++ b/src/Propellor/Property/Munin.hs
@@ -46,8 +46,8 @@ hostListFragment' hs os = concatMap muninHost hs
where
muninHost :: Host -> [String]
muninHost h = [ "[" ++ (hostName h) ++ "]"
- , " address " ++ maybe (hostName h) (fromIPAddr . fst) (hOverride h)
- ] ++ (maybe [] (\x -> [" port " ++ (fromPort $ snd x)]) (hOverride h)) ++ [""]
+ , " address " ++ maybe (hostName h) (val . fst) (hOverride h)
+ ] ++ (maybe [] (\x -> [" port " ++ (val $ snd x)]) (hOverride h)) ++ [""]
hOverride :: Host -> Maybe (IPAddr, Port)
hOverride h = lookup (hostName h) os
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 9ed9e591..b581fa3f 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -7,6 +7,9 @@ import Data.Char
type Interface = String
+-- | Options to put in a stanza of an ifupdown interfaces file.
+type InterfaceOptions = [(String, String)]
+
ifUp :: Interface -> Property DebianLike
ifUp iface = tightenTargets $ cmdProperty "ifup" [iface]
`assume` MadeChange
@@ -19,27 +22,57 @@ ifUp iface = tightenTargets $ cmdProperty "ifup" [iface]
--
-- No interfaces are brought up or down by this property.
cleanInterfacesFile :: Property DebianLike
-cleanInterfacesFile = tightenTargets $ hasContent interfacesFile
- [ "# Deployed by propellor, do not edit."
- , ""
- , "source-directory interfaces.d"
+cleanInterfacesFile = interfaceFileContains interfacesFile
+ [ "source-directory interfaces.d"
, ""
, "# The loopback network interface"
, "auto lo"
, "iface lo inet loopback"
]
+ []
`describe` ("clean " ++ interfacesFile)
-- | Configures an interface to get its address via dhcp.
dhcp :: Interface -> Property DebianLike
-dhcp iface = tightenTargets $ hasContent (interfaceDFile iface)
+dhcp iface = dhcp' iface mempty
+
+dhcp' :: Interface -> InterfaceOptions -> Property DebianLike
+dhcp' iface options = interfaceFileContains (interfaceDFile iface)
[ "auto " ++ iface
, "iface " ++ iface ++ " inet dhcp"
- ]
+ ] options
`describe` ("dhcp " ++ iface)
`requires` interfacesDEnabled
--- | Writes a static interface file for the specified interface.
+newtype Gateway = Gateway IPAddr
+
+-- | Configures an interface with a static address and gateway.
+static :: Interface -> IPAddr -> Maybe Gateway -> Property DebianLike
+static iface addr gateway = static' iface addr gateway mempty
+
+static' :: Interface -> IPAddr -> Maybe Gateway -> InterfaceOptions -> Property DebianLike
+static' iface addr gateway options =
+ interfaceFileContains (interfaceDFile iface) headerlines options'
+ `describe` ("static IP address for " ++ iface)
+ `requires` interfacesDEnabled
+ where
+ headerlines =
+ [ "auto " ++ iface
+ , "iface " ++ iface ++ " " ++ inet ++ " static"
+ ]
+ options' = catMaybes
+ [ Just $ ("address", val addr)
+ , case gateway of
+ Just (Gateway gaddr) ->
+ Just ("gateway", val gaddr)
+ Nothing -> Nothing
+ ] ++ options
+ inet = case addr of
+ IPv4 _ -> "inet"
+ IPv6 _ -> "inet6"
+
+-- | Writes a static interface file for the specified interface
+-- to preserve its current configuration.
--
-- The interface has to be up already. It could have been brought up by
-- DHCP, or by other means. The current ipv4 addresses
@@ -50,8 +83,8 @@ dhcp iface = tightenTargets $ hasContent (interfaceDFile iface)
--
-- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.)
-static :: Interface -> Property DebianLike
-static iface = tightenTargets $
+preserveStatic :: Interface -> Property DebianLike
+preserveStatic iface = tightenTargets $
check (not <$> doesFileExist f) setup
`describe` desc
`requires` interfacesDEnabled
@@ -84,13 +117,13 @@ static iface = tightenTargets $
-- | 6to4 ipv6 connection, should work anywhere
ipv6to4 :: Property DebianLike
-ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0")
- [ "# Deployed by propellor, do not edit."
+ipv6to4 = tightenTargets $ interfaceFileContains (interfaceDFile "sit0")
+ [ "auto sit0"
, "iface sit0 inet6 static"
- , "\taddress 2002:5044:5531::1"
- , "\tnetmask 64"
- , "\tgateway ::192.88.99.1"
- , "auto sit0"
+ ]
+ [ ("address", "2002:5044:5531::1")
+ , ("netmask", "64")
+ , ("gateway", "::192.88.99.1")
]
`describe` "ipv6to4"
`requires` interfacesDEnabled
@@ -114,3 +147,10 @@ interfacesDEnabled :: Property DebianLike
interfacesDEnabled = tightenTargets $
containsLine interfacesFile "source-directory interfaces.d"
`describe` "interfaces.d directory enabled"
+
+interfaceFileContains :: FilePath -> [String] -> InterfaceOptions -> Property DebianLike
+interfaceFileContains f headerlines options = tightenTargets $ hasContent f $
+ warning : headerlines ++ map fmt options
+ where
+ fmt (k, v) = "\t" ++ k ++ " " ++ v
+ warning = "# Deployed by propellor, do not edit."
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index d974cfbc..c31bef7b 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -64,7 +64,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey"
-- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property Linux
+cleanInstallOnce :: Confirmation -> Property DebianLike
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
@@ -207,7 +207,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
- ensureProperty w $ Network.static iface
+ ensureProperty w $ Network.preserveStatic iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 5bf3ff06..7943b46e 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -1,6 +1,9 @@
-- | Support for the Obnam backup tool <http://obnam.org/>
+--
+-- This module is deprecated because Obnam has been retired by its
+-- author.
-module Propellor.Property.Obnam where
+module Propellor.Property.Obnam {-# DEPRECATED "Obnam has been retired; time to transition to something else" #-} where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
@@ -150,7 +153,7 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps)
go (KeepWeeks n) = mk n 'w'
go (KeepMonths n) = mk n 'm'
go (KeepYears n) = mk n 'y'
- mk n c = show n ++ [c]
+ mk n c = val n ++ [c]
isKeepParam :: ObnamParam -> Bool
isKeepParam p = "--keep=" `isPrefixOf` p
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index 0abf38a6..00daa57d 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -28,7 +28,7 @@ providerFor users hn mp = propertyList desc $ props
where
baseurl = hn ++ case mp of
Nothing -> ""
- Just p -> ':' : fromPort p
+ Just p -> ':' : val p
url = "http://"++baseurl++"/simpleid"
desc = "openid provider " ++ url
setbaseurl l
diff --git a/src/Propellor/Property/Pacman.hs b/src/Propellor/Property/Pacman.hs
new file mode 100644
index 00000000..60ed4bea
--- /dev/null
+++ b/src/Propellor/Property/Pacman.hs
@@ -0,0 +1,68 @@
+-- | Maintainer: Zihao Wang <dev@wzhd.org>
+--
+-- Support for the Pacman package manager <https://www.archlinux.org/pacman/>
+
+module Propellor.Property.Pacman where
+
+import Propellor.Base
+
+runPacman :: [String] -> UncheckedProperty ArchLinux
+runPacman ps = tightenTargets $ cmdProperty "pacman" ps
+
+-- | Have pacman update its lists of packages, but without upgrading anything.
+update :: Property ArchLinux
+update = combineProperties ("pacman update") $ props
+ & runPacman ["-Sy", "--noconfirm"]
+ `assume` MadeChange
+
+upgrade :: Property ArchLinux
+upgrade = combineProperties ("pacman upgrade") $ props
+ & runPacman ["-Syu", "--noconfirm"]
+ `assume` MadeChange
+
+type Package = String
+
+installed :: [Package] -> Property ArchLinux
+installed = installed' ["--noconfirm"]
+
+installed' :: [String] -> [Package] -> Property ArchLinux
+installed' params ps = check (not <$> isInstalled' ps) go
+ `describe` unwords ("pacman installed":ps)
+ where
+ go = runPacman (params ++ ["-S"] ++ ps)
+
+removed :: [Package] -> Property ArchLinux
+removed ps = check (any (== IsInstalled) <$> getInstallStatus ps)
+ (runPacman (["-R", "--noconfirm"] ++ ps))
+ `describe` unwords ("pacman removed":ps)
+
+isInstalled :: Package -> IO Bool
+isInstalled p = isInstalled' [p]
+
+isInstalled' :: [Package] -> IO Bool
+isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps
+
+data InstallStatus = IsInstalled | NotInstalled
+ deriving (Show, Eq)
+
+{- Returns the InstallStatus of packages that are installed
+ - or known and not installed. If a package is not known at all to apt
+ - or dpkg, it is not included in the list. -}
+getInstallStatus :: [Package] -> IO [InstallStatus]
+getInstallStatus ps = mapMaybe id <$> mapM status ps
+ where
+ status :: Package -> IO (Maybe InstallStatus)
+ status p = do
+ ifM (succeeds "pacman" ["-Q", p])
+ (return (Just IsInstalled),
+ ifM (succeeds "pacman" ["-Sp", p])
+ (return (Just NotInstalled),
+ return Nothing))
+
+succeeds :: String -> [String] -> IO Bool
+succeeds cmd args = (quietProcess >> return True)
+ `catchIO` (\_ -> return False)
+ where
+ quietProcess :: IO ()
+ quietProcess = withQuietOutput createProcessSuccess p
+ p = (proc cmd args)
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index bc8a256d..43744142 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
module Propellor.Property.Parted (
+ -- * Types
TableType(..),
PartTable(..),
partTableSize,
@@ -15,136 +16,30 @@ module Propellor.Property.Parted (
Partition.MkfsOpts,
PartType(..),
PartFlag(..),
- Eep(..),
+ -- * Properties
partitioned,
parted,
+ Eep(..),
installed,
+ -- * PartSpec combinators
+ calcPartTable,
+ DiskSize(..),
+ DiskPart,
+ module Propellor.Types.PartSpec,
+ DiskSpaceUse(..),
+ useDiskSpace,
) where
import Propellor.Base
+import Propellor.Property.Parted.Types
import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Property.Partition as Partition
+import Propellor.Types.PartSpec
import Utility.DataUnits
-import Data.Char
-import System.Posix.Files
-
-class PartedVal a where
- val :: a -> String
-
--- | Types of partition tables supported by parted.
-data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN
- deriving (Show)
-
-instance PartedVal TableType where
- val = map toLower . show
-
--- | A disk's partition table.
-data PartTable = PartTable TableType [Partition]
- deriving (Show)
-
-instance Monoid PartTable where
- -- | default TableType is MSDOS
- mempty = PartTable MSDOS []
- -- | uses the TableType of the second parameter
- mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2)
-
--- | Gets the total size of the disk specified by the partition table.
-partTableSize :: PartTable -> ByteSize
-partTableSize (PartTable _ ps) = fromPartSize $
- -- add 1 megabyte to hold the partition table itself
- mconcat (MegaBytes 1 : map partSize ps)
-
--- | A partition on the disk.
-data Partition = Partition
- { partType :: PartType
- , partSize :: PartSize
- , partFs :: Partition.Fs
- , partMkFsOpts :: Partition.MkfsOpts
- , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default)
- , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC)
- }
- deriving (Show)
-
--- | Makes a Partition with defaults for non-important values.
-mkPartition :: Partition.Fs -> PartSize -> Partition
-mkPartition fs sz = Partition
- { partType = Primary
- , partSize = sz
- , partFs = fs
- , partMkFsOpts = []
- , partFlags = []
- , partName = Nothing
- }
-
--- | Type of a partition.
-data PartType = Primary | Logical | Extended
- deriving (Show)
-
-instance PartedVal PartType where
- val Primary = "primary"
- val Logical = "logical"
- val Extended = "extended"
-
--- | All partition sizing is done in megabytes, so that parted can
--- automatically lay out the partitions.
---
--- Note that these are SI megabytes, not mebibytes.
-newtype PartSize = MegaBytes Integer
- deriving (Show)
-
-instance PartedVal PartSize where
- val (MegaBytes n)
- | n > 0 = show n ++ "MB"
- -- parted can't make partitions smaller than 1MB;
- -- avoid failure in edge cases
- | otherwise = show "1MB"
--- | Rounds up to the nearest MegaByte.
-toPartSize :: ByteSize -> PartSize
-toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double)
-
-fromPartSize :: PartSize -> ByteSize
-fromPartSize (MegaBytes b) = b * 1000000
-
-instance Monoid PartSize where
- mempty = MegaBytes 0
- mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)
-
-reducePartSize :: PartSize -> PartSize -> PartSize
-reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b)
-
--- | Flags that can be set on a partition.
-data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag
- deriving (Show)
-
-instance PartedVal PartFlag where
- val BootFlag = "boot"
- val RootFlag = "root"
- val SwapFlag = "swap"
- val HiddenFlag = "hidden"
- val RaidFlag = "raid"
- val LvmFlag = "lvm"
- val LbaFlag = "lba"
- val LegacyBootFlag = "legacy_boot"
- val IrstFlag = "irst"
- val EspFlag = "esp"
- val PaloFlag = "palo"
-
-instance PartedVal Bool where
- val True = "on"
- val False = "off"
-
-instance PartedVal Partition.Fs where
- val Partition.EXT2 = "ext2"
- val Partition.EXT3 = "ext3"
- val Partition.EXT4 = "ext4"
- val Partition.BTRFS = "btrfs"
- val Partition.REISERFS = "reiserfs"
- val Partition.XFS = "xfs"
- val Partition.FAT = "fat"
- val Partition.VFAT = "vfat"
- val Partition.NTFS = "ntfs"
- val Partition.LinuxSwap = "linux-swap"
+import System.Posix.Files
+import Data.List (genericLength)
data Eep = YesReallyDeleteDiskContents
@@ -167,19 +62,19 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
format (p, dev) = Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition (partFs p) dev
- mklabel = ["mklabel", val tabletype]
+ mklabel = ["mklabel", pval tabletype]
mkflag partnum (f, b) =
[ "set"
, show partnum
- , val f
- , val b
+ , pval f
+ , pval b
]
mkpart partnum offset p =
[ "mkpart"
- , val (partType p)
- , val (partFs p)
- , val offset
- , val (offset <> partSize p)
+ , pval (partType p)
+ , pval (partFs p)
+ , pval offset
+ , pval (offset <> partSize p)
] ++ case partName p of
Just n -> ["name", show partnum, n]
Nothing -> []
@@ -192,12 +87,76 @@ partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
--
-- Parted is run in script mode, so it will never prompt for input.
-- It is asked to use cylinder alignment for the disk.
-parted :: Eep -> FilePath -> [String] -> Property DebianLike
+parted :: Eep -> FilePath -> [String] -> Property (DebianLike + ArchLinux)
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
`assume` MadeChange
-- | Gets parted installed.
-installed :: Property DebianLike
-installed = Apt.installed ["parted"]
+installed :: Property (DebianLike + ArchLinux)
+installed = Apt.installed ["parted"] `pickOS` Pacman.installed ["parted"]
+
+-- | Gets the total size of the disk specified by the partition table.
+partTableSize :: PartTable -> ByteSize
+partTableSize (PartTable _ ps) = fromPartSize $
+ mconcat (partitionTableOverhead : map partSize ps)
+
+-- | Some disk is used to store the partition table itself. Assume less
+-- than 1 mb.
+partitionTableOverhead :: PartSize
+partitionTableOverhead = MegaBytes 1
+
+-- | Calculate a partition table, for a given size of disk.
+--
+-- For example:
+--
+-- > calcPartTable (DiskSize (1024 * 1024 * 1024 * 100)) MSDOS
+-- > [ partition EXT2 `mountedAt` "/boot"
+-- > `setSize` MegaBytes 256
+-- > `setFlag` BootFlag
+-- > , partition EXT4 `mountedAt` "/"
+-- > `useDisk` RemainingSpace
+-- > ]
+calcPartTable :: DiskSize -> TableType -> [PartSpec DiskPart] -> PartTable
+calcPartTable (DiskSize disksize) tt l = PartTable tt (map go l)
+ where
+ go (_, _, mkpart, FixedDiskPart) = mkpart defSz
+ go (_, _, mkpart, DynamicDiskPart (Percent p)) = mkpart $ toPartSize $
+ diskremainingafterfixed * fromIntegral p `div` 100
+ go (_, _, mkpart, DynamicDiskPart RemainingSpace) = mkpart $ toPartSize $
+ diskremaining `div` genericLength (filter isremainingspace l)
+ diskremainingafterfixed =
+ disksize - sumsizes (filter isfixed l)
+ diskremaining =
+ disksize - sumsizes (filter (not . isremainingspace) l)
+ sumsizes = sum . map fromPartSize . (partitionTableOverhead :) .
+ map (partSize . go)
+ isfixed (_, _, _, FixedDiskPart) = True
+ isfixed _ = False
+ isremainingspace (_, _, _, DynamicDiskPart RemainingSpace) = True
+ isremainingspace _ = False
+
+-- | Size of a disk, in bytes.
+newtype DiskSize = DiskSize ByteSize
+ deriving (Show)
+
+data DiskPart = FixedDiskPart | DynamicDiskPart DiskSpaceUse
+
+data DiskSpaceUse = Percent Int | RemainingSpace
+
+instance Monoid DiskPart
+ where
+ mempty = FixedDiskPart
+ mappend FixedDiskPart FixedDiskPart = FixedDiskPart
+ mappend (DynamicDiskPart (Percent a)) (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent (a + b))
+ mappend (DynamicDiskPart RemainingSpace) (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace
+ mappend (DynamicDiskPart (Percent a)) _ = DynamicDiskPart (Percent a)
+ mappend _ (DynamicDiskPart (Percent b)) = DynamicDiskPart (Percent b)
+ mappend (DynamicDiskPart RemainingSpace) _ = DynamicDiskPart RemainingSpace
+ mappend _ (DynamicDiskPart RemainingSpace) = DynamicDiskPart RemainingSpace
+
+-- | Make a partition use some percentage of the size of the disk
+-- (less all fixed size partitions), or the remaining space in the disk.
+useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart
+useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse)
diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs
new file mode 100644
index 00000000..3350e008
--- /dev/null
+++ b/src/Propellor/Property/Parted/Types.hs
@@ -0,0 +1,119 @@
+module Propellor.Property.Parted.Types where
+
+import Propellor.Base
+import qualified Propellor.Property.Partition as Partition
+import Utility.DataUnits
+
+import Data.Char
+
+class PartedVal a where
+ pval :: a -> String
+
+-- | Types of partition tables supported by parted.
+data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN
+ deriving (Show)
+
+instance PartedVal TableType where
+ pval = map toLower . show
+
+-- | A disk's partition table.
+data PartTable = PartTable TableType [Partition]
+ deriving (Show)
+
+instance Monoid PartTable where
+ -- | default TableType is MSDOS
+ mempty = PartTable MSDOS []
+ -- | uses the TableType of the second parameter
+ mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2)
+
+-- | A partition on the disk.
+data Partition = Partition
+ { partType :: PartType
+ , partSize :: PartSize
+ , partFs :: Partition.Fs
+ , partMkFsOpts :: Partition.MkfsOpts
+ , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default)
+ , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC)
+ }
+ deriving (Show)
+
+-- | Makes a Partition with defaults for non-important values.
+mkPartition :: Partition.Fs -> PartSize -> Partition
+mkPartition fs sz = Partition
+ { partType = Primary
+ , partSize = sz
+ , partFs = fs
+ , partMkFsOpts = []
+ , partFlags = []
+ , partName = Nothing
+ }
+
+-- | Type of a partition.
+data PartType = Primary | Logical | Extended
+ deriving (Show)
+
+instance PartedVal PartType where
+ pval Primary = "primary"
+ pval Logical = "logical"
+ pval Extended = "extended"
+
+-- | All partition sizing is done in megabytes, so that parted can
+-- automatically lay out the partitions.
+--
+-- Note that these are SI megabytes, not mebibytes.
+newtype PartSize = MegaBytes Integer
+ deriving (Show)
+
+instance PartedVal PartSize where
+ pval (MegaBytes n)
+ | n > 0 = val n ++ "MB"
+ -- parted can't make partitions smaller than 1MB;
+ -- avoid failure in edge cases
+ | otherwise = "1MB"
+
+-- | Rounds up to the nearest MegaByte.
+toPartSize :: ByteSize -> PartSize
+toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double)
+
+fromPartSize :: PartSize -> ByteSize
+fromPartSize (MegaBytes b) = b * 1000000
+
+instance Monoid PartSize where
+ mempty = MegaBytes 0
+ mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b)
+
+reducePartSize :: PartSize -> PartSize -> PartSize
+reducePartSize (MegaBytes a) (MegaBytes b) = MegaBytes (a - b)
+
+-- | Flags that can be set on a partition.
+data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag
+ deriving (Show)
+
+instance PartedVal PartFlag where
+ pval BootFlag = "boot"
+ pval RootFlag = "root"
+ pval SwapFlag = "swap"
+ pval HiddenFlag = "hidden"
+ pval RaidFlag = "raid"
+ pval LvmFlag = "lvm"
+ pval LbaFlag = "lba"
+ pval LegacyBootFlag = "legacy_boot"
+ pval IrstFlag = "irst"
+ pval EspFlag = "esp"
+ pval PaloFlag = "palo"
+
+instance PartedVal Bool where
+ pval True = "on"
+ pval False = "off"
+
+instance PartedVal Partition.Fs where
+ pval Partition.EXT2 = "ext2"
+ pval Partition.EXT3 = "ext3"
+ pval Partition.EXT4 = "ext4"
+ pval Partition.BTRFS = "btrfs"
+ pval Partition.REISERFS = "reiserfs"
+ pval Partition.XFS = "xfs"
+ pval Partition.FAT = "fat"
+ pval Partition.VFAT = "vfat"
+ pval Partition.NTFS = "ntfs"
+ pval Partition.LinuxSwap = "linux-swap"
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 2bf5b927..679675b7 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -9,6 +9,7 @@ import Utility.Applicative
import System.Posix.Files
import Data.List
+import Data.Char
-- | Filesystems etc that can be used for a partition.
data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
@@ -81,11 +82,26 @@ kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
return r
cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
+-- kpartx's output includes the device for the loop partition, and some
+-- information about the whole disk loop device. In earlier versions,
+-- this was simply the path to the loop device. But, in kpartx 0.6,
+-- this changed to the major:minor of the block device. Either is handled
+-- by this parser.
kpartxParse :: String -> [LoopDev]
kpartxParse = mapMaybe (finddev . words) . lines
where
- finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev
- { partitionLoopDev = "/dev/mapper/" ++ ld
- , wholeDiskLoopDev = wd
- }
+ finddev ("add":"map":ld:_:_:_:_:s:_) = do
+ wd <- if isAbsolute s
+ then Just s
+ -- A loop partition name loop0pn corresponds to
+ -- /dev/loop0. It would be more robust to check
+ -- that the major:minor matches, but haskell's
+ -- unix library lacks a way to do that.
+ else case takeWhile isDigit (dropWhile (not . isDigit) ld) of
+ [] -> Nothing
+ n -> Just $ "/dev" </> "loop" ++ n
+ Just $ LoopDev
+ { partitionLoopDev = "/dev/mapper/" ++ ld
+ , wholeDiskLoopDev = wd
+ }
finddev _ = Nothing
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 31731dc2..909d87fb 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -59,7 +59,7 @@ atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
-- See 'Propellor.Property.HostingProvider.DigitalOcean'
-- for an example of how to do this.
toDistroKernel :: Property DebianLike
-toDistroKernel = check (not <$> runningInstalledKernel) now
+toDistroKernel = tightenTargets $ check (not <$> runningInstalledKernel) now
`describe` "running installed kernel"
-- | Given a kernel version string @v@, reboots immediately if the running
@@ -78,15 +78,16 @@ toKernelNewerThan ver =
property' ("reboot to kernel newer than " ++ ver) $ \w -> do
wantV <- tryReadVersion ver
runningV <- tryReadVersion =<< liftIO runningKernelVersion
- installedV <- maximum <$>
- (mapM tryReadVersion =<< liftIO installedKernelVersions)
if runningV >= wantV then noChange
- else if installedV >= wantV
- then ensureProperty w now
- else errorMessage $
- "kernel newer than "
- ++ ver
- ++ " not installed"
+ else maximum <$> installedVs >>= \installedV ->
+ if installedV >= wantV
+ then ensureProperty w now
+ else errorMessage $
+ "kernel newer than "
+ ++ ver
+ ++ " not installed"
+ where
+ installedVs = mapM tryReadVersion =<< liftIO installedKernelVersions
runningInstalledKernel :: IO Bool
runningInstalledKernel = do
diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs
new file mode 100644
index 00000000..d9d4d4be
--- /dev/null
+++ b/src/Propellor/Property/Restic.hs
@@ -0,0 +1,202 @@
+-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
+--
+-- Support for the restic backup tool <https://github.com/restic/restic>
+
+module Propellor.Property.Restic
+ ( ResticRepo (..)
+ , installed
+ , repoExists
+ , init
+ , restored
+ , backup
+ , backup'
+ , KeepPolicy (..)
+ ) where
+
+import Propellor.Base hiding (init)
+import Prelude hiding (init)
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Cron as Cron
+import qualified Propellor.Property.File as File
+import Data.List (intercalate)
+
+type Url = String
+
+type ResticParam = String
+
+data ResticRepo
+ = Direct FilePath
+ | SFTP User HostName FilePath
+ | REST Url
+
+instance ConfigurableValue ResticRepo where
+ val (Direct fp) = fp
+ val (SFTP u h fp) = "sftp:" ++ val u ++ "@" ++ val h ++ ":" ++ fp
+ val (REST url) = "rest:" ++ url
+
+installed :: Property DebianLike
+installed = withOS desc $ \w o -> case o of
+ (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $
+ Apt.installedBackport ["restic"]
+ _ -> ensureProperty w $
+ Apt.installed ["restic"]
+ where
+ desc = "installed restic"
+
+repoExists :: ResticRepo -> IO Bool
+repoExists repo = boolSystem "restic"
+ [ Param "-r"
+ , File (val repo)
+ , Param "--password-file"
+ , File (getPasswordFile repo)
+ , Param "snapshots"
+ ]
+
+passwordFileDir :: FilePath
+passwordFileDir = "/etc/restic-keys"
+
+getPasswordFile :: ResticRepo -> FilePath
+getPasswordFile repo = passwordFileDir </> File.configFileName (val repo)
+
+passwordFileConfigured :: ResticRepo -> Property (HasInfo + UnixLike)
+passwordFileConfigured repo = propertyList "restic password file" $ props
+ & File.dirExists passwordFileDir
+ & File.mode passwordFileDir 0O2700
+ & getPasswordFile repo `File.hasPrivContent` hostContext
+
+-- | Inits a new restic repository
+init :: ResticRepo -> Property (HasInfo + DebianLike)
+init repo = check (not <$> repoExists repo) (cmdProperty "restic" initargs)
+ `requires` installed
+ `requires` passwordFileConfigured repo
+ where
+ initargs =
+ [ "-r"
+ , val repo
+ , "--password-file"
+ , getPasswordFile repo
+ , "init"
+ ]
+
+-- | Restores a directory from a restic backup.
+--
+-- Only does anything if the directory does not exist, or exists,
+-- but is completely empty.
+--
+-- The restore is performed atomically; restoring to a temp directory
+-- and then moving it to the directory.
+restored :: FilePath -> ResticRepo -> Property (HasInfo + DebianLike)
+restored dir repo = go
+ `requires` init repo
+ where
+ go :: Property DebianLike
+ go = property (dir ++ " restored by restic") $ ifM (liftIO needsRestore)
+ ( do
+ warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
+ liftIO restore
+ , noChange
+ )
+
+ needsRestore = null <$> catchDefaultIO [] (dirContents dir)
+
+ restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do
+ ok <- boolSystem "restic"
+ [ Param "-r"
+ , File (val repo)
+ , Param "--password-file"
+ , File (getPasswordFile repo)
+ , Param "restore"
+ , Param "latest"
+ , Param "--target"
+ , File tmpdir
+ ]
+ let restoreddir = tmpdir ++ "/" ++ dir
+ ifM (pure ok <&&> doesDirectoryExist restoreddir)
+ ( do
+ void $ tryIO $ removeDirectory dir
+ renameDirectory restoreddir dir
+ return MadeChange
+ , return FailedChange
+ )
+
+-- | Installs a cron job that causes a given directory to be backed
+-- up, by running restic with some parameters.
+--
+-- If the directory does not exist, or exists but is completely empty,
+-- this Property will immediately restore it from an existing backup.
+--
+-- So, this property can be used to deploy a directory of content
+-- to a host, while also ensuring any changes made to it get backed up.
+-- For example:
+--
+-- > & Restic.backup "/srv/git"
+-- > (Restic.SFTP (User root) (HostName myserver) /mnt/backup/git.restic")
+-- > Cron.Daily
+-- > ["--exclude=/srv/git/tobeignored"]
+-- > [Restic.KeepDays 7, Restic.KeepWeeks 4, Restic.KeepMonths 6, Restic.KeepYears 1]
+--
+-- Since restic uses a fair amount of system resources, only one restic
+-- backup job will be run at a time. Other jobs will wait their turns to
+-- run.
+backup :: FilePath -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike)
+backup dir repo crontimes extraargs kp = backup' [dir] repo crontimes extraargs kp
+ `requires` restored dir repo
+
+-- | Does a backup, but does not automatically restore.
+backup' :: [FilePath] -> ResticRepo -> Cron.Times -> [ResticParam] -> [KeepPolicy] -> Property (HasInfo + DebianLike)
+backup' dirs repo crontimes extraargs kp = cronjob
+ `describe` desc
+ `requires` init repo
+ where
+ desc = val repo ++ " restic backup"
+ cronjob = Cron.niceJob ("restic_backup" ++ intercalate "_" dirs) crontimes (User "root") "/" $
+ "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd
+ lockfile = "/var/lock/propellor-restic.lock"
+ backupcmd = intercalate " && " $
+ createCommand
+ : if null kp then [] else [pruneCommand]
+ createCommand = unwords $
+ [ "restic"
+ , "-r"
+ , shellEscape (val repo)
+ , "--password-file"
+ , shellEscape (getPasswordFile repo)
+ ]
+ ++ map shellEscape extraargs ++
+ [ "backup" ]
+ ++ map shellEscape dirs
+ pruneCommand = unwords $
+ [ "restic"
+ , "-r"
+ , shellEscape (val repo)
+ , "--password-file"
+ , shellEscape (getPasswordFile repo)
+ , "forget"
+ , "--prune"
+ ]
+ ++
+ map keepParam kp
+
+-- | Constructs a ResticParam that specifies which old backup generations to
+-- keep. By default, all generations are kept. However, when this parameter is
+-- passed to the `backup` property, they will run restic prune to clean out
+-- generations not specified here.
+keepParam :: KeepPolicy -> ResticParam
+keepParam (KeepLast n) = "--keep-last=" ++ val n
+keepParam (KeepHours n) = "--keep-hourly=" ++ val n
+keepParam (KeepDays n) = "--keep-daily=" ++ val n
+keepParam (KeepWeeks n) = "--keep-weekly=" ++ val n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ val n
+keepParam (KeepYears n) = "--keep-yearly=" ++ val n
+
+-- | Policy for backup generations to keep. For example, KeepDays 30 will
+-- keep the latest backup for each day when a backup was made, and keep the
+-- last 30 such backups. When multiple KeepPolicies are combined together,
+-- backups meeting any policy are kept. See restic's man page for details.
+data KeepPolicy
+ = KeepLast Int
+ | KeepHours Int
+ | KeepDays Int
+ | KeepWeeks Int
+ | KeepMonths Int
+ | KeepYears Int
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index b40396de..d922e79f 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -2,6 +2,7 @@ module Propellor.Property.Rsync where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Pacman as Pacman
type Src = FilePath
type Dest = FilePath
@@ -16,7 +17,7 @@ filesUnder d = Pattern (d ++ "/*")
-- | Ensures that the Dest directory exists and has identical contents as
-- the Src directory.
-syncDir :: Src -> Dest -> Property DebianLike
+syncDir :: Src -> Dest -> Property (DebianLike + ArchLinux)
syncDir = syncDirFiltered []
data Filter
@@ -43,9 +44,9 @@ newtype Pattern = Pattern String
-- Rsync checks each name to be transferred against its list of Filter
-- rules, and the first matching one is acted on. If no matching rule
-- is found, the file is processed.
-syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property (DebianLike + ArchLinux)
syncDirFiltered filters src dest = rsync $
- [ "-av"
+ [ "-a"
-- Add trailing '/' to get rsync to sync the Dest directory,
-- rather than a subdir inside it, which it will do without a
-- trailing '/'.
@@ -53,10 +54,13 @@ syncDirFiltered filters src dest = rsync $
, addTrailingPathSeparator dest
, "--delete"
, "--delete-excluded"
- , "--quiet"
+ , "--info=progress2"
] ++ map toRsync filters
-rsync :: [String] -> Property DebianLike
+rsync :: [String] -> Property (DebianLike + ArchLinux)
rsync ps = cmdProperty "rsync" ps
`assume` MadeChange
- `requires` Apt.installed ["rsync"]
+ `requires` installed
+
+installed :: Property (DebianLike + ArchLinux)
+installed = Apt.installed ["rsync"] `pickOS` Pacman.installed ["rsync"]
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index c3e55bbf..23f3b311 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -20,12 +20,10 @@ Debian stretch, which older sbuild can't handle.
Suggested usage in @config.hs@:
-> & Apt.installed ["piuparts", "autopkgtest"]
+> & Apt.installed ["piuparts", "autopkgtest", "lintian"]
> & Sbuild.builtFor (System (Debian Linux Unstable) X86_32) Sbuild.UseCcache
-> & Sbuild.piupartsConfFor (System (Debian Linux Unstable) X86_32)
> & Sbuild.updatedFor (System (Debian Linux Unstable) X86_32) `period` Weekly 1
> & Sbuild.usableBy (User "spwhitton")
-> & Sbuild.shareAptCache
> & Schroot.overlaysInTmpfs
If you are using sbuild older than 0.70.0, you also need:
@@ -34,15 +32,13 @@ If you are using sbuild older than 0.70.0, you also need:
In @~/.sbuildrc@ (sbuild 0.71.0 or newer):
-> $run_piuparts = 1;
> $piuparts_opts = [
+> '--no-eatmydata',
> '--schroot',
-> '%r-%a-piuparts',
+> '%r-%a-sbuild',
> '--fail-if-inadequate',
-> '--fail-on-broken-symlinks',
> ];
>
-> $run_autopkgtest = 1;
> $autopkgtest_root_args = "";
> $autopkgtest_opts = ["--", "schroot", "%r-%a-sbuild"];
@@ -53,9 +49,9 @@ propellor spin pulls in a lot of dependencies. This could defeat
using sbuild to determine if you've included all necessary build
dependencies in your source package control file.
-Nevertheless, the chroot that @sbuild-createchroot(1)@ creates might
-not meet your needs. For example, you might need to enable an apt
-cacher. In that case you can do something like this in @config.hs@:
+Nevertheless, the chroot that @sbuild-createchroot(1)@ creates might not meet
+your needs. For example, you might need to enable apt's https support. In that
+case you can do something like this in @config.hs@:
> & Sbuild.built (System (Debian Linux Unstable) X86_32) `before` mySetup
> where
@@ -74,20 +70,19 @@ module Propellor.Property.Sbuild (
UseCcache(..),
built,
updated,
- piupartsConf,
builtFor,
updatedFor,
- piupartsConfFor,
-- * Global sbuild configuration
-- blockNetwork,
installed,
keypairGenerated,
keypairInsecurelyGenerated,
- shareAptCache,
usableBy,
+ userConfig,
) where
import Propellor.Base
+import Propellor.Types.Info
import Propellor.Property.Debootstrap (extractSuite)
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Apt as Apt
@@ -98,10 +93,10 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.Schroot as Schroot
import qualified Propellor.Property.Reboot as Reboot
import qualified Propellor.Property.User as User
-
import Utility.FileMode
+import Utility.Split
+
import Data.List
-import Data.List.Utils
type Suite = String
@@ -111,8 +106,8 @@ type Suite = String
-- the same suite and the same architecture, so neither do we
data SbuildSchroot = SbuildSchroot Suite Architecture
-instance Show SbuildSchroot where
- show (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
+instance ConfigurableValue SbuildSchroot where
+ val (SbuildSchroot suite arch) = suite ++ "-" ++ architectureToDebianArchString arch
-- | Whether an sbuild schroot should use ccache during builds
--
@@ -128,9 +123,9 @@ data UseCcache = UseCcache | NoCcache
builtFor :: System -> UseCcache -> RevertableProperty DebianLike UnixLike
builtFor sys cc = go <!> deleted
where
- go = property' ("sbuild schroot for " ++ show sys) $
- \w -> case (schrootFromSystem sys, stdMirror sys) of
- (Just s, Just u) -> ensureProperty w $
+ go = Apt.withMirror goDesc $ \u -> property' goDesc $ \w ->
+ case schrootFromSystem sys of
+ Just s -> ensureProperty w $
setupRevertableProperty $ built s u cc
_ -> errorMessage
("don't know how to debootstrap " ++ show sys)
@@ -139,6 +134,7 @@ builtFor sys cc = go <!> deleted
Just s -> ensureProperty w $
undoRevertableProperty $ built s "dummy" cc
Nothing -> noChange
+ goDesc = "sbuild schroot for " ++ show sys
-- | Build and configure a schroot for use with sbuild
built :: SbuildSchroot -> Apt.Url -> UseCcache -> RevertableProperty DebianLike UnixLike
@@ -146,12 +142,13 @@ built s@(SbuildSchroot suite arch) mirror cc =
((go `before` enhancedConf)
`requires` ccacheMaybePrepared cc
`requires` installed
- `requires` overlaysKernel)
+ `requires` overlaysKernel
+ `requires` cleanupOldConfig)
<!> deleted
where
go :: Property DebianLike
go = check (unpopulated (schrootRoot s) <||> ispartial) $
- property' ("built sbuild schroot for " ++ show s) make
+ property' ("built sbuild schroot for " ++ val s) make
make w = do
de <- liftIO standardPathEnv
let params = Param <$>
@@ -170,22 +167,49 @@ built s@(SbuildSchroot suite arch) mirror cc =
-- TODO we should kill any sessions still using the chroot
-- before destroying it (as suggested by sbuild-destroychroot)
deleted = check (not <$> unpopulated (schrootRoot s)) $
- property ("no sbuild schroot for " ++ show s) $ do
+ property ("no sbuild schroot for " ++ val s) $ do
liftIO $ removeChroot $ schrootRoot s
liftIO $ nukeFile
- ("/etc/sbuild/chroot" </> show s ++ "-sbuild")
+ ("/etc/sbuild/chroot" </> val s ++ "-sbuild")
makeChange $ nukeFile (schrootConf s)
enhancedConf =
- combineProperties ("enhanced schroot conf for " ++ show s) $ props
+ combineProperties ("enhanced schroot conf for " ++ val s) $ props
& aliasesLine
+ -- set up an apt proxy/cacher
+ & proxyCacher
-- enable ccache and eatmydata for speed
& ConfFile.containsIniSetting (schrootConf s)
- ( show s ++ "-sbuild"
+ ( val s ++ "-sbuild"
, "command-prefix"
, intercalate "," commandPrefix
)
+ -- set the apt proxy inside the chroot. If the host has an apt proxy
+ -- set, assume that it does some sort of caching. Otherwise, set up a
+ -- local apt-cacher-ng instance
+ --
+ -- (if we didn't assume that the apt proxy does some sort of caching,
+ -- we'd need to complicate the Apt.HostAptProxy type to indicate whether
+ -- the proxy caches, and if it doesn't, set up apt-cacher-ng as an
+ -- intermediary proxy between the chroot's apt and the Apt.HostAptProxy
+ -- proxy. This complexity is more likely to cause problems than help
+ -- anyone)
+ proxyCacher :: Property DebianLike
+ proxyCacher = property' "set schroot apt proxy" $ \w -> do
+ proxyInfo <- getProxyInfo
+ ensureProperty w $ case proxyInfo of
+ Just (Apt.HostAptProxy u) -> setChrootProxy u
+ Nothing -> (Apt.serviceInstalledRunning "apt-cacher-ng"
+ `before` setChrootProxy "http://localhost:3142")
+ where
+ getProxyInfo :: Propellor (Maybe Apt.HostAptProxy)
+ getProxyInfo = fromInfoVal <$> askInfo
+ setChrootProxy :: Apt.Url -> Property DebianLike
+ setChrootProxy u = tightenTargets $ File.hasContent
+ (schrootRoot s </> "etc/apt/apt.conf.d/20proxy")
+ [ "Acquire::HTTP::Proxy \"" ++ u ++ "\";" ]
+
-- if we're building a sid chroot, add useful aliases
-- In order to avoid more than one schroot getting the same aliases, we
-- only do this if the arch of the chroot equals the host arch.
@@ -196,7 +220,7 @@ built s@(SbuildSchroot suite arch) mirror cc =
then ensureProperty w $
ConfFile.containsIniSetting
(schrootConf s)
- ( show s ++ "-sbuild"
+ ( val s ++ "-sbuild"
, "aliases"
, aliases
)
@@ -217,6 +241,21 @@ built s@(SbuildSchroot suite arch) mirror cc =
Reboot.toKernelNewerThan "3.18"
else noChange
+ -- clean up config from earlier versions of this module
+ cleanupOldConfig :: Property UnixLike
+ cleanupOldConfig =
+ property' "old sbuild module config cleaned up" $ \w -> do
+ void $ ensureProperty w $
+ check (doesFileExist fstab)
+ (File.lacksLine fstab aptCacheLine)
+ void $ liftIO . tryIO $ removeDirectoryRecursive profile
+ void $ liftIO $ nukeFile (schrootPiupartsConf s)
+ -- assume this did nothing
+ noChange
+ where
+ fstab = "/etc/schroot/sbuild/fstab"
+ profile = "/etc/schroot/piuparts"
+
-- A failed debootstrap run will leave a debootstrap directory;
-- recover by deleting it and trying again.
ispartial = ifM (doesDirectoryExist (schrootRoot s </> "debootstrap"))
@@ -263,7 +302,7 @@ updatedFor system = property' ("updated sbuild schroot for " ++ show system) $
updated :: SbuildSchroot -> Property DebianLike
updated s@(SbuildSchroot suite arch) =
check (doesDirectoryExist (schrootRoot s)) $ go
- `describe` ("updated schroot for " ++ show s)
+ `describe` ("updated schroot for " ++ val s)
`requires` installed
where
go :: Property DebianLike
@@ -283,13 +322,13 @@ updated s@(SbuildSchroot suite arch) =
-- given suite and architecture, so we don't need the suffix to be random.
fixConfFile :: SbuildSchroot -> Property UnixLike
fixConfFile s@(SbuildSchroot suite arch) =
- property' ("schroot for " ++ show s ++ " config file fixed") $ \w -> do
+ property' ("schroot for " ++ val s ++ " config file fixed") $ \w -> do
confs <- liftIO $ dirContents dir
let old = concat $ filter (tempPrefix `isPrefixOf`) confs
liftIO $ moveFile old new
liftIO $ moveFile
- ("/etc/sbuild/chroot" </> show s ++ "-propellor")
- ("/etc/sbuild/chroot" </> show s ++ "-sbuild")
+ ("/etc/sbuild/chroot" </> val s ++ "-propellor")
+ ("/etc/sbuild/chroot" </> val s ++ "-sbuild")
ensureProperty w $
File.fileProperty "replace dummy suffix" (map munge) new
where
@@ -298,92 +337,6 @@ fixConfFile s@(SbuildSchroot suite arch) =
tempPrefix = dir </> suite ++ "-" ++ architectureToDebianArchString arch ++ "-propellor-"
munge = replace "-propellor]" "-sbuild]"
--- | Create a corresponding schroot config file for use with piuparts
---
--- This function is a convenience wrapper around 'piupartsConf', allowing the
--- user to identify the schroot using the 'System' type. See that function's
--- documentation for why you might want to use this property, and sample config.
-piupartsConfFor :: System -> Property DebianLike
-piupartsConfFor sys = property' ("piuparts schroot conf for " ++ show sys) $
- \w -> case schrootFromSystem sys of
- Just s -> ensureProperty w $ piupartsConf s
- _ -> errorMessage
- ("don't know how to debootstrap " ++ show sys)
-
--- | Create a corresponding schroot config file for use with piuparts
---
--- This is useful because:
---
--- - piuparts will clear out the apt cache which makes 'shareAptCache' much less
--- useful
---
--- - piuparts itself invokes eatmydata, so the command-prefix setting in our
--- regular schroot config would force the user to pass @--no-eatmydata@ to
--- piuparts in their @~/.sbuildrc@, which is inconvenient.
---
--- To make use of this new schroot config, you can put something like this in
--- your ~/.sbuildrc (sbuild 0.71.0 or newer):
---
--- > $run_piuparts = 1;
--- > $piuparts_opts = [
--- > '--schroot',
--- > '%r-%a-piuparts',
--- > '--fail-if-inadequate',
--- > '--fail-on-broken-symlinks',
--- > ];
---
--- This property has no effect if the corresponding sbuild schroot does not
--- exist (i.e. you also need 'Sbuild.built' or 'Sbuild.builtFor').
-piupartsConf :: SbuildSchroot -> Property DebianLike
-piupartsConf s@(SbuildSchroot _ arch) =
- check (doesFileExist (schrootConf s)) go
- `requires` installed
- where
- go :: Property DebianLike
- go = property' desc $ \w -> do
- aliases <- aliasesLine
- ensureProperty w $ combineProperties desc $ props
- & check (not <$> doesFileExist f)
- (File.basedOn f (schrootConf s, map munge))
- & ConfFile.containsIniSetting f
- (sec, "profile", "piuparts")
- & ConfFile.containsIniSetting f
- (sec, "aliases", aliases)
- & ConfFile.containsIniSetting f
- (sec, "command-prefix", "")
- & File.dirExists dir
- & File.isSymlinkedTo (dir </> "copyfiles")
- (File.LinkTarget $ orig </> "copyfiles")
- & File.isSymlinkedTo (dir </> "nssdatabases")
- (File.LinkTarget $ orig </> "nssdatabases")
- & File.basedOn (dir </> "fstab")
- (orig </> "fstab", filter (/= aptCacheLine))
-
- orig = "/etc/schroot/sbuild"
- dir = "/etc/schroot/piuparts"
- sec = show s ++ "-piuparts"
- f = schrootPiupartsConf s
- munge = replace "-sbuild]" "-piuparts]"
- desc = "piuparts schroot conf for " ++ show s
-
- -- normally the piuparts schroot conf has no aliases, but we have to add
- -- one, for dgit compatibility, if this is the default sid chroot
- aliasesLine = sidHostArchSchroot s >>= \isSidHostArchSchroot ->
- return $ if isSidHostArchSchroot
- then "UNRELEASED-"
- ++ architectureToDebianArchString arch
- ++ "-piuparts"
- else ""
-
--- | Bind-mount /var/cache/apt/archives in all sbuild chroots so that the host
--- system and the chroot share the apt cache
---
--- This speeds up builds by avoiding unnecessary downloads of build
--- dependencies.
-shareAptCache :: Property DebianLike
-shareAptCache = File.containsLine "/etc/schroot/sbuild/fstab" aptCacheLine
- `requires` installed
- `describe` "sbuild schroots share host apt cache"
aptCacheLine :: String
aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0"
@@ -493,6 +446,35 @@ ccachePrepared = propertyList "sbuild group ccache configured" $ props
-- [Firewall.IPWithNumMask (IPv4 "127.0.0.1") 8])
-- `requires` installed -- sbuild group must exist
+-- | Maintain recommended ~/.sbuildrc for a user, and adds them to the
+-- sbuild group
+--
+-- You probably want a custom ~/.sbuildrc on your workstation, but
+-- this property is handy for quickly setting up build boxes.
+userConfig :: User -> Property DebianLike
+userConfig user@(User u) = go
+ `requires` usableBy user
+ `requires` Apt.installed ["piuparts", "autopkgtest", "lintian"]
+ where
+ go :: Property DebianLike
+ go = property' ("~/.sbuildrc for " ++ u) $ \w -> do
+ h <- liftIO (User.homedir user)
+ ensureProperty w $ File.hasContent (h </> ".sbuildrc")
+ [ "$run_lintian = 1;"
+ , ""
+ , "$run_piuparts = 1;"
+ , "$piuparts_opts = ["
+ , " '--no-eatmydata',"
+ , " '--schroot',"
+ , " '%r-%a-sbuild',"
+ , " '--fail-if-inadequate',"
+ , " ];"
+ , ""
+ , "$run_autopkgtest = 1;"
+ , "$autopkgtest_root_args = \"\";"
+ , "$autopkgtest_opts = [\"--\", \"schroot\", \"%r-%a-sbuild\"];"
+ ]
+
-- ==== utility functions ====
schrootFromSystem :: System -> Maybe SbuildSchroot
@@ -500,11 +482,6 @@ schrootFromSystem system@(System _ arch) =
extractSuite system
>>= \suite -> return $ SbuildSchroot suite arch
-stdMirror :: System -> Maybe Apt.Url
-stdMirror (System (Debian _ _) _) = Just "http://httpredir.debian.org/debian"
-stdMirror (System (Buntish _) _) = Just "mirror://mirrors.ubuntu.com/"
-stdMirror _ = Nothing
-
schrootRoot :: SbuildSchroot -> FilePath
schrootRoot (SbuildSchroot s a) = "/srv/chroot" </> s ++ "-" ++ architectureToDebianArchString a
@@ -527,7 +504,7 @@ schrootPiupartsConf (SbuildSchroot s a) =
sidHostArchSchroot :: SbuildSchroot -> Propellor Bool
sidHostArchSchroot (SbuildSchroot suite arch) = do
maybeOS <- getOS
- case maybeOS of
- Nothing -> return False
+ return $ case maybeOS of
+ Nothing -> False
Just (System _ hostArch) ->
- return $ suite == "unstable" && hostArch == arch
+ suite == "unstable" && hostArch == arch
diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs
index 239bcbeb..ce679083 100644
--- a/src/Propellor/Property/SiteSpecific/Branchable.hs
+++ b/src/Propellor/Property/SiteSpecific/Branchable.hs
@@ -8,6 +8,8 @@ import qualified Propellor.Property.Ssh as Ssh
import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Sudo as Sudo
+import qualified Propellor.Property.Borg as Borg
+import qualified Propellor.Property.Cron as Cron
server :: [Host] -> Property (HasInfo + DebianLike)
server hosts = propertyList "branchable server" $ props
@@ -37,18 +39,24 @@ server hosts = propertyList "branchable server" $ props
& Postfix.installed
& Postfix.mainCf ("mailbox_command", "procmail -a \"$EXTENSION\"")
- -- Obnam is run by a cron job in ikiwiki-hosting.
- & "/etc/obnam.conf" `File.hasContent`
- [ "[config]"
- , "repository = sftp://joey@eubackup.kitenet.net/home/joey/lib/backup/pell.obnam"
- , "log = /var/log/obnam.log"
- , "encrypt-with = " ++ obnamkey
- , "log-level = info"
- , "log-max = 1048576"
- , "keep = 7d,5w,12m"
- , "upload-queue-size = 128"
- , "lru-size = 128"
+ & Borg.backup "/" "joey@eubackup.kitenet.net:/home/joey/lib/backup/branchable/pell.borg" Cron.Daily
+ [ "--exclude=/proc/*"
+ , "--exclude=/sys/*"
+ , "--exclude=/run/*"
+ , "--exclude=/tmp/*"
+ , "--exclude=/var/tmp/*"
+ , "--exclude=/var/backups/ikiwiki-hosting-web/*"
+ , "--exclude=/var/cache/*"
+ , "--exclude=/home/*/source/*"
+ , "--exclude=/home/*/public_html/*"
+ , "--exclude=/home/*/.git/*"
]
+ [ Borg.KeepDays 7
+ , Borg.KeepWeeks 5
+ , Borg.KeepMonths 12
+ , Borg.KeepYears 1
+ ]
+ -- gpg key that can be used to decrypt the borg backup key
& Gpg.keyImported (Gpg.GpgKeyId obnamkey) (User "root")
& Ssh.userKeys (User "root") (Context "branchable.com")
[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC2PqTSupwncqeffNwZQXacdEWp7L+TxllIxH7WjfRMb3U74mQxWI0lwqLVW6Fox430DvhSqF1y5rJBvTHh4i49Tc9lZ7mwAxA6jNOP6bmdfteaKKYmUw5qwtJW0vISBFu28qBO11Nq3uJ1D3Oj6N+b3mM/0D3Y3NoGgF8+2dLdi81u9+l6AQ5Jsnozi2Ni/Osx2oVGZa+IQDO6gX8VEP4OrcJFNJe8qdnvItcGwoivhjbIfzaqNNvswKgGzhYLOAS5KT8HsjvIpYHWkyQ5QUX7W/lqGSbjP+6B8C3tkvm8VLXbmaD+aSkyCaYbuoXC2BoJdS7Jh8phKMwPJmdYVepn")
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index d40964b3..bd4d0928 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -143,15 +143,15 @@ stackAutoBuilder suite arch flavor =
stackInstalled :: Property Linux
stackInstalled = withOS "stack installed" $ \w o ->
case o of
- (Just (System (Debian Linux (Stable "jessie")) X86_32)) ->
- ensureProperty w $ manualinstall X86_32
+ (Just (System (Debian Linux (Stable "jessie")) arch)) ->
+ ensureProperty w $ manualinstall arch
_ -> ensureProperty w $ Apt.installed ["haskell-stack"]
where
-- Warning: Using a binary downloaded w/o validation.
manualinstall :: Architecture -> Property Linux
manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $
propertyList "stack installed from upstream tarball" $ props
- & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ architectureToDebianArchString arch, "-O", tmptar]
+ & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ archname, "-O", tmptar]
`assume` MadeChange
& File.dirExists tmpdir
& cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
@@ -160,6 +160,15 @@ stackInstalled = withOS "stack installed" $ \w o ->
`assume` MadeChange
& cmdProperty "rm" ["-rf", tmpdir, tmptar]
`assume` MadeChange
+ where
+ -- See https://www.stackage.org/stack/ for the list of
+ -- binaries.
+ archname = case arch of
+ X86_32 -> "i386"
+ X86_64 -> "x86_64"
+ ARMHF -> "arm"
+ -- Probably not available.
+ a -> architectureToDebianArchString a
binstack = "/usr/bin/stack"
tmptar = "/root/stack.tar.gz"
tmpdir = "/root/stack"
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index d8991cb1..d4263031 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -19,13 +19,14 @@ import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Apache as Apache
import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Systemd as Systemd
+import qualified Propellor.Property.Network as Network
import qualified Propellor.Property.Fail2Ban as Fail2Ban
import qualified Propellor.Property.LetsEncrypt as LetsEncrypt
import Utility.FileMode
+import Utility.Split
import Data.List
import System.Posix.Files
-import Data.String.Utils
scrollBox :: Property (HasInfo + DebianLike)
scrollBox = propertyList "scroll server" $ props
@@ -78,7 +79,8 @@ scrollBox = propertyList "scroll server" $ props
`onChange` Ssh.restarted
& User.shellSetTo (User "scroll") s
& User.hasPassword (User "scroll")
- & Apt.serviceInstalledRunning "telnetd"
+ -- telnetd attracted password crackers, so disabled
+ & Apt.removed ["telnetd"]
& Apt.installed ["shellinabox"]
& File.hasContent "/etc/default/shellinabox"
[ "# Deployed by propellor"
@@ -227,23 +229,29 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root")
`requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net")
`requires` User.accountFor (User "family")
- & Apt.installed ["git", "rsync", "gitweb"]
+ & Apt.installed ["git", "rsync", "cgit"]
& Apt.installed ["git-annex"]
& Apt.installed ["kgb-client"]
& File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext
`requires` File.dirExists "/etc/kgb-bot/"
& Git.daemonRunning "/srv/git"
- & "/etc/gitweb.conf" `File.containsLines`
- [ "$projectroot = '/srv/git';"
- , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
- , "# disable snapshot download; overloads server"
- , "$feature{'snapshot'}{'default'} = [];"
- ]
- `describe` "gitweb configured"
- -- Repos push on to github.
- & Ssh.knownHost hosts "github.com" (User "joey")
- -- I keep the website used for gitweb checked into git..
- & Git.cloned (User "root") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+ & "/etc/cgitrc" `File.hasContent`
+ [ "clone-url=https://git.joeyh.name/git/$CGIT_REPO_URL git://git.joeyh.name/$CGIT_REPO_URL"
+ , "css=/cgit-css/cgit.css"
+ , "logo=/cgit-css/cgit.png"
+ , "enable-http-clone=1"
+ , "root-title=Joey's git repositories"
+ , "root-desc="
+ , "enable-index-owner=0"
+ , "snapshots=tar.gz"
+ , "enable-git-config=1"
+ , "scan-path=/srv/git"
+ ]
+ `describe` "cgit configured"
+ -- I keep the website used for git.kitenet.net/git.joeyh.name checked into git..
+ & Git.cloned (User "joey") "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+ -- Don't need global apache configuration for cgit.
+ ! Apache.confEnabled "cgit"
& website "git.kitenet.net"
& website "git.joeyh.name"
& Apache.modEnabled "cgi"
@@ -313,9 +321,9 @@ apacheSite hn middle = Apache.siteEnabled hn $ apachecfg hn middle
apachecfg :: HostName -> Apache.ConfigFile -> Apache.ConfigFile
apachecfg hn middle =
- [ "<VirtualHost *:"++show port++">"
+ [ "<VirtualHost *:" ++ val port ++ ">"
, " ServerAdmin grue@joeyh.name"
- , " ServerName "++hn++":"++show port
+ , " ServerName "++hn++":" ++ val port
]
++ middle ++
[ ""
@@ -328,7 +336,7 @@ apachecfg hn middle =
, "</VirtualHost>"
]
where
- port = 80 :: Int
+ port = Port 80
gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
@@ -369,7 +377,7 @@ tmp = propertyList "tmp.joeyh.name" $ props
-- (Obsolete; need to revert this.)
pumpRss :: Property DebianLike
pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.joeyh.name/"
- "wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
+ "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
ircBouncer :: Property (HasInfo + DebianLike)
ircBouncer = propertyList "IRC bouncer" $ props
@@ -404,8 +412,6 @@ githubBackup = propertyList "github-backup box" $ props
& githubKeys
& Cron.niceJob "github-backup run" (Cron.Times "30 4 * * *") (User "joey")
"/home/joey/lib/backup" backupcmd
- & Cron.niceJob "gitriddance" (Cron.Times "30 4 * * *") (User "joey")
- "/home/joey/lib/backup" gitriddancecmd
where
backupcmd = intercalate "&&" $
[ "mkdir -p github"
@@ -413,11 +419,6 @@ githubBackup = propertyList "github-backup box" $ props
, ". $HOME/.github-keys"
, "github-backup joeyh"
]
- gitriddancecmd = intercalate "&&" $
- [ "cd github"
- , ". $HOME/.github-keys"
- ] ++ map gitriddance githubMirrors
- gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
githubKeys :: Property (HasInfo + UnixLike)
githubKeys =
@@ -426,19 +427,6 @@ githubKeys =
`onChange` File.ownerGroup f (User "joey") (Group "joey")
--- these repos are only mirrored on github, I don't want
--- all the proprietary features
-githubMirrors :: [(String, String)]
-githubMirrors =
- [ ("ikiwiki", plzuseurl "http://ikiwiki.info/todo/")
- , ("git-annex", plzuseurl "http://git-annex.branchable.com/todo/")
- , ("myrepos", plzuseurl "http://myrepos.branchable.com/todo/")
- , ("propellor", plzuseurl "http://propellor.branchable.com/todo/")
- , ("etckeeper", plzuseurl "http://etckeeper.branchable.com/todo/")
- ]
- where
- plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess"
-
rsyncNetBackup :: [Host] -> Property DebianLike
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *")
(User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
@@ -452,16 +440,6 @@ backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc
desc = "backups copied from " ++ srchost ++ " on boot"
cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir </> srchost
-obnamRepos :: [String] -> Property UnixLike
-obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $
- toProps (mkbase : map mkrepo rs)
- where
- mkbase = mkdir "/home/joey/lib/backup"
- `requires` mkdir "/home/joey/lib"
- mkrepo r = mkdir ("/home/joey/lib/backup/" ++ r ++ ".obnam")
- mkdir d = File.dirExists d
- `before` File.ownerGroup d (User "joey") (Group "joey")
-
podcatcher :: Property DebianLike
podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *")
(User "joey") "/home/joey/lib/sound/podcasts"
@@ -586,8 +564,8 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
, "# Enable postgrey."
, "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023"
- , "# Enable spamass-milter, amavis-milter, opendkim"
- , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891"
+ , "# Enable spamass-milter, amavis-milter (opendkim is not enabled because it causes mails forwarded from eg gmail to be rejected)"
+ , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock"
, "# opendkim is used for outgoing mail"
, "non_smtpd_milters = inet:localhost:8891"
, "milter_connect_macros = j {daemon_name} v {if_name} _"
@@ -694,6 +672,10 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
& File.ownerGroup "/etc/mail/dkim.key" (User "opendkim") (Group "opendkim")
& "/etc/default/opendkim" `File.containsLine`
"SOCKET=\"inet:8891@localhost\""
+ `onChange`
+ (cmdProperty "/lib/opendkim/opendkim.service.generate" []
+ `assume` MadeChange)
+ `onChange` Service.restarted "opendkim"
& "/etc/opendkim.conf" `File.containsLines`
[ "KeyFile /etc/mail/dkim.key"
, "SubDomains yes"
@@ -707,9 +689,20 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
-hasJoeyCAChain :: Property (HasInfo + UnixLike)
-hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
- Context "joeyca.pem"
+postfixSaslPasswordClient :: Property (HasInfo + DebianLike)
+postfixSaslPasswordClient = combineProperties "postfix uses SASL password to authenticate with smarthost" $ props
+ & Postfix.satellite
+ & Postfix.mappedFile "/etc/postfix/sasl_passwd"
+ (`File.hasPrivContent` (Context "kitenet.net"))
+ & Postfix.mainCfFile `File.containsLines`
+ [ "# TLS setup for SASL auth to kite"
+ , "smtp_sasl_auth_enable = yes"
+ , "smtp_tls_security_level = encrypt"
+ , "smtp_sasl_tls_security_options = noanonymous"
+ , "relayhost = [kitenet.net]"
+ , "smtp_sasl_password_maps = hash:/etc/postfix/sasl_passwd"
+ ]
+ `onChange` Postfix.reloaded
hasPostfixCert :: Context -> Property (HasInfo + UnixLike)
hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props
@@ -790,6 +783,15 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "# Redirect all to joeyh.name."
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
+ & alias "homepower.joeyh.name"
+ & apacheSite "homepower.joeyh.name"
+ [ "DocumentRoot /srv/web/homepower.joeyh.name"
+ , "<Directory /srv/web/homepower.joeyh.name>"
+ , " Options Indexes ExecCGI"
+ , " AllowOverride None"
+ , Apache.allowAll
+ , "</Directory>"
+ ]
where
kitenetcfg =
-- /var/www is empty
@@ -891,7 +893,7 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
-- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/>
--
-- oncalendar example value: "*-*-* 7:30"
-alarmClock :: String -> User -> String -> Property DebianLike
+alarmClock :: String -> User -> String -> Property Linux
alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props
& "/etc/systemd/system/goodmorning.timer" `File.hasContent`
[ "[Unit]"
@@ -925,3 +927,124 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer
& Systemd.started "goodmorning.timer"
& "/etc/systemd/logind.conf" `ConfFile.containsIniSetting`
("Login", "LidSwitchIgnoreInhibited", "no")
+
+-- My home power monitor.
+homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike)
+homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props
+ & Apache.installed
+ & Apt.installed ["python2", "python-pymodbus"]
+ & File.ownerGroup "/var/www/html" user (userGroup user)
+ & Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing
+ `onChange` buildpoller
+ & Systemd.enabled servicename
+ `requires` serviceinstalled
+ `onChange` Systemd.started servicename
+ & Cron.niceJob "homepower upload"
+ (Cron.Times "1 * * * *") user d rsynccommand
+ `requires` Ssh.userKeyAt (Just sshkeyfile) user ctx sshkey
+ where
+ d = "/var/www/html/homepower"
+ sshkeyfile = d </> ".ssh/key"
+ buildpoller = userScriptProperty (User "joey")
+ [ "cd " ++ d
+ , "make"
+ ]
+ `assume` MadeChange
+ `requires` Apt.installed ["ghc", "make"]
+ servicename = "homepower"
+ servicefile = "/etc/systemd/system/" ++ servicename ++ ".service"
+ serviceinstalled = servicefile `File.hasContent`
+ [ "[Unit]"
+ , "Description=home power monitor"
+ , ""
+ , "[Service]"
+ , "ExecStart=" ++ d ++ "/poller"
+ , "WorkingDirectory=" ++ d
+ , "User=joey"
+ , "Group=joey"
+ , ""
+ , "[Install]"
+ , "WantedBy=multi-user.target"
+ ]
+ -- Only upload when eth0 is up; eg the satellite internet is up.
+ -- Any changes to the rsync command will need my .authorized_keys
+ -- rsync server command to be updated too.
+ rsynccommand = "if ip route | grep '^default' | grep -q eth0; then rsync -e 'ssh -i" ++ sshkeyfile ++ "' -avz rrds/recent/ joey@kitenet.net:/srv/web/homepower.joeyh.name/rrds/recent/; fi"
+
+-- My home router, running hostapd and dnsmasq for wlan0,
+-- with eth0 connected to a satellite modem, and a fallback ppp connection.
+homeRouter :: Property (HasInfo + DebianLike)
+homeRouter = propertyList "home router" $ props
+ & Network.static "wlan0" (IPv4 "10.1.1.1") Nothing
+ `requires` Network.cleanInterfacesFile
+ & Apt.serviceInstalledRunning "hostapd"
+ `requires` File.hasContent "/etc/hostapd/hostapd.conf"
+ [ "interface=wlan0"
+ , "ssid=house"
+ , "hw_mode=g"
+ , "channel=8"
+ ]
+ `requires` File.dirExists "/lib/hostapd"
+ & Apt.serviceInstalledRunning "dnsmasq"
+ `requires` File.hasContent "/etc/dnsmasq.conf"
+ [ "domain-needed"
+ , "bogus-priv"
+ , "interface=wlan0"
+ , "domain=kitenet.net"
+ , "dhcp-range=10.1.1.100,10.1.1.150,24h"
+ , "no-hosts"
+ , "address=/honeybee.kitenet.net/10.1.1.1"
+ ]
+ `requires` File.hasContent "/etc/resolv.conf"
+ [ "domain kitenet.net"
+ , "search kitenet.net"
+ , "nameserver 8.8.8.8"
+ , "nameserver 8.8.4.4"
+ ]
+ & ipmasq "wlan0"
+ & Apt.serviceInstalledRunning "netplug"
+ & Network.dhcp' "eth0"
+ -- When satellite is down, fall back to dialup
+ [ ("pre-up", "poff -a || true")
+ , ("post-down", "pon")
+ ]
+ `requires` Network.cleanInterfacesFile
+ & Apt.installed ["ppp"]
+ `before` File.hasContent "/etc/ppp/peers/provider"
+ [ "user \"joeyh@arczip.com\""
+ , "connect \"/usr/sbin/chat -v -f /etc/chatscripts/pap -T 9734111\""
+ , "/dev/ttyACM0"
+ , "115200"
+ , "noipdefault"
+ , "defaultroute"
+ , "persist"
+ , "noauth"
+ ]
+ `before` File.hasPrivContent "/etc/ppp/pap-secrets" (Context "joeyh@arczip.com")
+
+-- | Enable IP masqerading, on whatever other interfaces come up than the
+-- provided intif.
+ipmasq :: String -> Property DebianLike
+ipmasq intif = File.hasContent ifupscript
+ [ "#!/bin/sh"
+ , "INTIF=" ++ intif
+ , "if [ \"$IFACE\" = $INTIF ] || [ \"$IFACE\" = lo ]; then"
+ , "exit 0"
+ , "fi"
+ , "iptables -F"
+ , "iptables -A FORWARD -i $IFACE -o $INTIF -m state --state ESTABLISHED,RELATED -j ACCEPT"
+ , "iptables -A FORWARD -i $INTIF -o $IFACE -j ACCEPT"
+ , "iptables -t nat -A POSTROUTING -o $IFACE -j MASQUERADE"
+ , "echo 1 > /proc/sys/net/ipv4/ip_forward"
+ ]
+ `before` scriptmode ifupscript
+ `before` File.hasContent pppupscript
+ [ "#!/bin/sh"
+ , "IFACE=$PPP_IFACE " ++ ifupscript
+ ]
+ `before` scriptmode pppupscript
+ `requires` Apt.installed ["iptables"]
+ where
+ ifupscript = "/etc/network/if-up.d/ipmasq"
+ pppupscript = "/etc/ppp/ip-up.d/ipmasq"
+ scriptmode f = f `File.mode` combineModes (readModes ++ executeModes)
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index bce522f6..fd89f97a 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -69,11 +69,11 @@ setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
setSshdConfig :: ConfigKeyword -> String -> Property DebianLike
-setSshdConfig setting val = File.fileProperty desc f sshdConfig
+setSshdConfig setting v = File.fileProperty desc f sshdConfig
`onChange` restarted
where
- desc = unwords [ "ssh config:", setting, val ]
- cfgline = setting ++ " " ++ val
+ desc = unwords [ "ssh config:", setting, v ]
+ cfgline = setting ++ " " ++ v
wantedline s
| s == cfgline = True
| (setting ++ " ") `isPrefixOf` s = False
@@ -120,7 +120,7 @@ dotFile f user = do
listenPort :: Port -> RevertableProperty DebianLike DebianLike
listenPort port = enable <!> disable
where
- portline = "Port " ++ fromPort port
+ portline = "Port " ++ val port
enable = sshdConfig `File.containsLine` portline
`describe` ("ssh listening on " ++ portline)
`onChange` restarted
@@ -227,7 +227,7 @@ newtype HostKeyInfo = HostKeyInfo
deriving (Eq, Ord, Typeable, Show)
instance IsInfo HostKeyInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid HostKeyInfo where
mempty = HostKeyInfo M.empty
@@ -248,7 +248,7 @@ newtype UserKeyInfo = UserKeyInfo
deriving (Eq, Ord, Typeable, Show)
instance IsInfo UserKeyInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid UserKeyInfo where
mempty = UserKeyInfo M.empty
diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs
index 45ab8af2..1614801d 100644
--- a/src/Propellor/Property/Sudo.hs
+++ b/src/Propellor/Property/Sudo.hs
@@ -9,23 +9,33 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user.
-enabledFor :: User -> Property DebianLike
-enabledFor user@(User u) = go `requires` Apt.installed ["sudo"]
+enabledFor :: User -> RevertableProperty DebianLike DebianLike
+enabledFor user@(User u) = setup `requires` Apt.installed ["sudo"] <!> cleanup
where
- go :: Property UnixLike
- go = property' desc $ \w -> do
+ setup :: Property UnixLike
+ setup = property' desc $ \w -> do
locked <- liftIO $ isLockedPassword user
ensureProperty w $
fileProperty desc
(modify locked . filter (wanted locked))
- "/etc/sudoers"
- desc = u ++ " is sudoer"
+ sudoers
+ where
+ desc = u ++ " is sudoer"
+
+ cleanup :: Property DebianLike
+ cleanup = tightenTargets $
+ fileProperty desc (filter notuserline) sudoers
+ where
+ desc = u ++ " is not sudoer"
+
+ sudoers = "/etc/sudoers"
sudobaseline = u ++ " ALL=(ALL:ALL)"
+ notuserline l = not (sudobaseline `isPrefixOf` l)
sudoline True = sudobaseline ++ " NOPASSWD:ALL"
sudoline False = sudobaseline ++ " ALL"
wanted locked l
-- TOOD: Full sudoers file format parse..
- | not (sudobaseline `isPrefixOf` l) = True
+ | notuserline l = True
| "NOPASSWD" `isInfixOf` l = locked
| otherwise = True
modify locked ls
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 78529f73..51d1313c 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -55,9 +55,9 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
import Propellor.Property.Systemd.Core
import Utility.FileMode
+import Utility.Split
import Data.List
-import Data.List.Utils
import qualified Data.Map as M
type ServiceName = String
@@ -259,7 +259,7 @@ debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux
-nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
+nspawned c@(Container name (Chroot.Chroot loc builder _ _) h) =
p `describe` ("nspawned " ++ name)
where
p :: RevertableProperty (HasInfo + Linux) Linux
@@ -271,7 +271,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- Chroot provisioning is run in systemd-only mode,
-- which sets up the chroot and ensures systemd and dbus are
-- installed, but does not handle the other properties.
- chrootprovisioned = Chroot.provisioned' (Chroot.propagateChrootInfo chroot) chroot True
+ chrootprovisioned = Chroot.provisioned' chroot True
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
@@ -281,56 +281,44 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
<!>
doNothing
- chroot = Chroot.Chroot loc builder h
+ chroot = Chroot.Chroot loc builder Chroot.propagateChrootInfo h
--- | Sets up the service file for the container, and then starts
--- it running.
+-- | Sets up the service files for the container, using the
+-- systemd-nspawn@.service template, and starts it running.
nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService (Container name _ _) cfg = setup <!> teardown
where
service = nspawnServiceName name
- servicefile = "/etc/systemd/system/multi-user.target.wants" </> service
-
- servicefilecontent = do
- ls <- lines <$> readFile "/lib/systemd/system/systemd-nspawn@.service"
- return $ unlines $
- "# deployed by propellor" : map addparams ls
- addparams l
- | "ExecStart=" `isPrefixOf` l = unwords $
- [ "ExecStart = /usr/bin/systemd-nspawn"
- , "--quiet"
- , "--keep-unit"
- , "--boot"
- , "--directory=" ++ containerDir name
- , "--machine=%i"
- ] ++ nspawnServiceParams cfg
- | otherwise = l
-
- goodservicefile = (==)
- <$> servicefilecontent
- <*> catchDefaultIO "" (readFile servicefile)
-
- writeservicefile :: Property Linux
- writeservicefile = property servicefile $ makeChange $ do
- c <- servicefilecontent
- File.viaStableTmp (\t -> writeFile t c) servicefile
-
- setupservicefile :: Property Linux
- setupservicefile = check (not <$> goodservicefile) $
- -- if it's running, it has the wrong configuration,
- -- so stop it
- stopped service
- `requires` daemonReloaded
- `requires` writeservicefile
+ overridedir = "/etc/systemd/system" </> nspawnServiceName name ++ ".d"
+ overridefile = overridedir </> "local.conf"
+ overridecontent =
+ [ "[Service]"
+ , "# Reset ExecStart from the template"
+ , "ExecStart="
+ , "ExecStart=/usr/bin/systemd-nspawn " ++ unwords nspawnparams
+ ]
+ nspawnparams =
+ [ "--quiet"
+ , "--keep-unit"
+ , "--boot"
+ , "--directory=" ++ containerDir name
+ , "--machine=" ++ name
+ ] ++ nspawnServiceParams cfg
+
+ overrideconfigured = File.hasContent overridefile overridecontent
+ `onChange` daemonReloaded
+ `requires` File.dirExists overridedir
setup :: Property Linux
setup = started service
- `requires` setupservicefile
+ `requires` enabled service
+ `requires` overrideconfigured
`requires` machined
teardown :: Property Linux
- teardown = check (doesFileExist servicefile) $
- disabled service `requires` stopped service
+ teardown = stopped service
+ `before` disabled service
+ `before` File.notPresent overridefile
nspawnServiceParams :: ChrootCfg -> [String]
nspawnServiceParams NoChrootCfg = []
@@ -421,7 +409,7 @@ class Publishable a where
toPublish :: a -> String
instance Publishable Port where
- toPublish port = fromPort port
+ toPublish port = val port
instance Publishable (Bound Port) where
toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v)
diff --git a/src/Propellor/Property/Timezone.hs b/src/Propellor/Property/Timezone.hs
new file mode 100644
index 00000000..96a5e59c
--- /dev/null
+++ b/src/Propellor/Property/Timezone.hs
@@ -0,0 +1,21 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Timezone where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+
+-- | A timezone from /usr/share/zoneinfo
+type Timezone = String
+
+-- | Sets the system's timezone
+configured :: Timezone -> Property DebianLike
+configured zone = File.hasContent "/etc/timezone" [zone]
+ `onChange` update
+ `describe` (zone ++ " timezone configured")
+ where
+ update = Apt.reConfigure "tzdata" mempty
+ -- work around a bug in recent tzdata. See
+ -- https://bugs.launchpad.net/ubuntu/+source/tzdata/+bug/1554806/
+ `requires` File.notPresent "/etc/localtime"
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index ea9f39ed..8794bc7f 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -53,12 +53,20 @@ named n = configured [("Nickname", n')]
where
n' = saneNickname n
+-- | Configures tor with secret_id_key, ed25519_master_id_public_key,
+-- and ed25519_master_id_secret_key from privdata.
torPrivKey :: Context -> Property (HasInfo + DebianLike)
-torPrivKey context = f `File.hasPrivContent` context
- `onChange` File.ownerGroup f user (userGroup user)
+torPrivKey context = mconcat (map go keyfiles)
+ `onChange` restarted
`requires` torPrivKeyDirExists
where
- f = torPrivKeyDir </> "secret_id_key"
+ keyfiles = map (torPrivKeyDir </>)
+ [ "secret_id_key"
+ , "ed25519_master_id_public_key"
+ , "ed25519_master_id_secret_key"
+ ]
+ go f = f `File.hasPrivContent` context
+ `onChange` File.ownerGroup f user (userGroup user)
torPrivKeyDirExists :: Property DebianLike
torPrivKeyDirExists = File.dirExists torPrivKeyDir
@@ -124,22 +132,30 @@ bandwidthRate' s divby = case readSize dataUnits s of
-- If used without `hiddenServiceData`, tor will generate a new
-- private key.
hiddenService :: HiddenServiceName -> Port -> Property DebianLike
-hiddenService hn (Port port) = ConfFile.adjustSection
- (unwords ["hidden service", hn, "available on port", show port])
+hiddenService hn port = hiddenService' hn [port]
+
+hiddenService' :: HiddenServiceName -> [Port] -> Property DebianLike
+hiddenService' hn ports = ConfFile.adjustSection
+ (unwords ["hidden service", hn, "available on ports", intercalate "," (map val ports')])
(== oniondir)
(not . isPrefixOf "HiddenServicePort")
- (const [oniondir, onionport])
- (++ [oniondir, onionport])
+ (const (oniondir : onionports))
+ (++ oniondir : onionports)
mainConfig
`onChange` restarted
where
oniondir = unwords ["HiddenServiceDir", varLib </> hn]
- onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
+ onionports = map onionport ports'
+ ports' = sort ports
+ onionport port = unwords ["HiddenServicePort", val port, "127.0.0.1:" ++ val port]
-- | Same as `hiddenService` but also causes propellor to display
-- the onion address of the hidden service.
hiddenServiceAvailable :: HiddenServiceName -> Port -> Property DebianLike
-hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
+hiddenServiceAvailable hn port = hiddenServiceAvailable' hn [port]
+
+hiddenServiceAvailable' :: HiddenServiceName -> [Port] -> Property DebianLike
+hiddenServiceAvailable' hn ports = hiddenServiceHostName $ hiddenService' hn ports
where
hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs
index 23a5b30d..470aad7e 100644
--- a/src/Propellor/Property/Unbound.hs
+++ b/src/Propellor/Property/Unbound.hs
@@ -133,10 +133,10 @@ genAddress dom ttl addr = case addr of
IPv6 _ -> genAddress' "AAAA" dom ttl addr
genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String
-genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr
+genAddress' recordtype dom ttl addr = dValue dom ++ " " ++ maybe "" (\ttl' -> val ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ val addr
genMX :: BindDomain -> Int -> BindDomain -> String
-genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest
+genMX dom priority dest = dValue dom ++ " " ++ "MX" ++ " " ++ val priority ++ " " ++ dValue dest
genPTR :: BindDomain -> ReverseIP -> String
genPTR dom revip = revip ++ ". " ++ "PTR" ++ " " ++ dValue dom
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index 76eae647..0b5bdddc 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -22,17 +22,18 @@ systemAccountFor :: User -> Property DebianLike
systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u))
systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike
-systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
+systemAccountFor' (User u) mhome mgroup = case mgroup of
+ Nothing -> prop
+ Just g -> prop
+ `requires` systemGroup g
`describe` ("system account for " ++ u)
where
+ prop = tightenTargets $ check nouser go
nouser = isNothing <$> catchMaybeIO (getUserEntryForName u)
go = cmdProperty "adduser" $
- [ "--system" ]
+ [ "--system", "--home" ]
++
- "--home" : maybe
- ["/nonexistent", "--no-create-home"]
- ( \h -> [ h ] )
- mhome
+ maybe ["/nonexistent", "--no-create-home"] ( \h -> [h] ) mhome
++
maybe [] ( \(Group g) -> ["--ingroup", g] ) mgroup
++
@@ -42,8 +43,18 @@ systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
, u
]
+systemGroup :: Group -> Property UnixLike
+systemGroup (Group g) = check nogroup go
+ `describe` ("system account for " ++ g)
+ where
+ nogroup = isNothing <$> catchMaybeIO (getGroupEntryForName g)
+ go = cmdProperty "addgroup"
+ [ "--system"
+ , g
+ ]
+
-- | Removes user home directory!! Use with caution.
-nuked :: User -> Eep -> Property DebianLike
+nuked :: User -> Eep -> Property Linux
nuked user@(User u) _ = tightenTargets $ check hashomedir go
`describe` ("nuked user " ++ u)
where
@@ -97,8 +108,12 @@ setPassword getpassword = getpassword $ go
-- | Makes a user's password be the passed String. Highly insecure:
-- The password is right there in your config file for anyone to see!
hasInsecurePassword :: User -> String -> Property DebianLike
-hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
- chpasswd u p []
+hasInsecurePassword u@(User n) p = go
+ `requires` shadowConfig True
+ where
+ go :: Property DebianLike
+ go = property (n ++ " has insecure password") $
+ chpasswd u p []
chpasswd :: User -> String -> [String] -> Propellor Result
chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess
@@ -107,7 +122,7 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc
hClose h
lockedPassword :: User -> Property DebianLike
-lockedPassword user@(User u) = tightenTargets $
+lockedPassword user@(User u) = tightenTargets $
check (not <$> isLockedPassword user) go
`describe` ("locked " ++ u ++ " password")
where
diff --git a/src/Propellor/Property/Versioned.hs b/src/Propellor/Property/Versioned.hs
new file mode 100644
index 00000000..87673c64
--- /dev/null
+++ b/src/Propellor/Property/Versioned.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}
+
+-- | Versioned properties and hosts.
+--
+-- When importing and using this module, you will need to enable some
+-- language extensions:
+--
+-- > {-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}
+--
+-- This module takes advantage of `RevertableProperty` to let propellor
+-- switch cleanly between versions. The way it works is all revertable
+-- properties for other versions than the current version are first
+-- reverted, and then propellor ensures the property for the current
+-- version. This method should work for any combination of revertable
+-- properties.
+--
+-- For example:
+--
+-- > demo :: Versioned Int (RevertableProperty DebianLike DebianLike)
+-- > demo ver =
+-- > ver ( (== 1) --> Apache.modEnabled "foo"
+-- > `requires` Apache.modEnabled "foosupport"
+-- > <|> (== 2) --> Apache.modEnabled "bar"
+-- > <|> (> 2) --> Apache.modEnabled "baz"
+-- > )
+-- >
+-- > foo :: Host
+-- > foo = host "foo.example.com" $ props
+-- > & demo `version` (2 :: Int)
+--
+-- Similarly, a whole Host can be versioned. For example:
+--
+-- > bar :: Versioned Int Host
+-- > bar ver = host "bar.example.com" $ props
+-- > & osDebian Unstable X86_64
+-- > & ver ( (== 1) --> Apache.modEnabled "foo"
+-- > <|> (== 2) --> Apache.modEnabled "bar"
+-- > )
+-- > & ver ( (>= 2) --> Apt.unattendedUpgrades )
+--
+-- Note that some versioning of revertable properties may cause
+-- propellor to do a lot of unnecessary work each time it's run.
+-- Here's an example of such a problem:
+--
+-- > slow :: Versioned Int -> RevertableProperty DebianLike DebianLike
+-- > slow ver =
+-- > ver ( (== 1) --> (Apt.installed "foo" <!> Apt.removed "foo")
+-- > <|> (== 2) --> (Apt.installed "bar" <!> Apt.removed "bar")
+-- > )
+--
+-- Suppose that package bar depends on package foo. Then at version 2,
+-- propellor will remove package foo in order to revert version 1, only
+-- to re-install it since version 2 also needs it installed.
+
+module Propellor.Property.Versioned (Versioned, version, (-->), (<|>)) where
+
+import Propellor
+import Propellor.Types.Core
+
+import Data.List
+
+-- | Something that has multiple versions of type `v`.
+type Versioned v t = VersionedBy v -> t
+
+type VersionedBy v
+ = forall metatypes. Combines (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes)
+ => (CombinedType (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) ~ RevertableProperty metatypes metatypes)
+ => (VerSpec v metatypes -> RevertableProperty metatypes metatypes)
+
+-- | Access a particular version of a Versioned value.
+version :: (Versioned v t) -> v -> t
+version f v = f (processVerSpec v)
+
+-- A specification of versions.
+--
+-- Why is this not a simple list like
+-- [(v -> Bool, RevertableProperty metatypes metatypes)] ?
+-- Using a list would mean the empty list would need to be dealt with,
+-- and processVerSpec does not have a Monoid instance for
+-- RevertableProperty metatypes metatypes in scope, and due to the way the
+-- Versioned type works, the compiler cannot find such an instance.
+--
+-- Also, using this data type allows a nice syntax for creating
+-- VerSpecs, via the `<&>` and `alt` functions.
+data VerSpec v metatypes
+ = Base (v -> Bool, RevertableProperty metatypes metatypes)
+ | More (v -> Bool, RevertableProperty metatypes metatypes) (VerSpec v metatypes)
+
+processVerSpec
+ :: Combines (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes)
+ => (CombinedType (RevertableProperty metatypes metatypes) (RevertableProperty metatypes metatypes) ~ RevertableProperty metatypes metatypes)
+ => v
+ -> VerSpec v metatypes
+ -> RevertableProperty metatypes metatypes
+processVerSpec v s = combinedp s
+ `describe` intercalate " and " (combineddesc s [])
+ where
+ combinedp (Base (c, p))
+ | c v = p
+ | otherwise = revert p
+ combinedp (More (c, p) vs)
+ | c v = combinedp vs `before` p
+ | otherwise = revert p `before` combinedp vs
+ combineddesc (Base (c, p)) l
+ | c v = getDesc p : l
+ | otherwise = getDesc (revert p) : l
+ combineddesc (More (c, p) vs) l
+ | c v = getDesc p : combineddesc vs l
+ | otherwise = getDesc (revert p) : combineddesc vs l
+
+-- | Specify a function that checks the version, and what
+-- `RevertableProperty` to use if the version matches.
+(-->) :: (v -> Bool) -> RevertableProperty metatypes metatypes -> VerSpec v metatypes
+c --> p = Base (c, p)
+
+-- | Add an alternate version.
+(<|>) :: VerSpec v metatypes -> VerSpec v metatypes -> VerSpec v metatypes
+Base a <|> Base b = More a (Base b)
+Base a <|> More b c = More a (More b c)
+More b c <|> Base a = More a (More b c)
+More a b <|> More c d = More a (More c (b <|> d))
+
+infixl 8 -->
+infixl 2 <|>
diff --git a/src/Propellor/Property/XFCE.hs b/src/Propellor/Property/XFCE.hs
new file mode 100644
index 00000000..dc57660f
--- /dev/null
+++ b/src/Propellor/Property/XFCE.hs
@@ -0,0 +1,41 @@
+module Propellor.Property.XFCE where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.User as User
+
+installed :: Property DebianLike
+installed = Apt.installed ["task-xfce-desktop"]
+ `describe` "XFCE desktop installed"
+
+-- | Minimal install of XFCE, with a terminal emulator and panel,
+-- and X and network-manager, but not any of the extra apps.
+installedMin :: Property DebianLike
+installedMin = Apt.installedMin ["xfce4", "xfce4-terminal", "task-desktop"]
+ `describe` "minimal XFCE desktop installed"
+
+-- | Installs network-manager-gnome, which is the way to get
+-- network-manager to manage networking in XFCE too.
+networkManager :: Property DebianLike
+networkManager = Apt.installedMin ["network-manager-gnome"]
+
+-- | Normally at first login, XFCE asks what kind of panel the user wants.
+-- This enables the default configuration noninteractively.
+defaultPanelFor :: User -> File.Overwrite -> Property DebianLike
+defaultPanelFor u@(User username) overwrite = property' desc $ \w -> do
+ home <- liftIO $ User.homedir u
+ ensureProperty w (go home)
+ where
+ desc = "default XFCE panel for " ++ username
+ basecf = ".config" </> "xfce4" </> "xfconf"
+ </> "xfce-perchannel-xml" </> "xfce4-panel.xml"
+ -- This location is probably Debian-specific.
+ defcf = "/etc/xdg/xfce4/panel/default.xml"
+ go :: FilePath -> Property DebianLike
+ go home = tightenTargets $
+ File.checkOverwrite overwrite (home </> basecf) $ \cf ->
+ cf `File.isCopyOf` defcf
+ `before` File.applyPath home basecf
+ (\f -> File.ownerGroup f u (userGroup u))
+ `requires` Apt.installed ["xfce4-panel"]
diff --git a/src/Propellor/Property/ZFS/Process.hs b/src/Propellor/Property/ZFS/Process.hs
index 372bac6d..42b23df2 100644
--- a/src/Propellor/Property/ZFS/Process.hs
+++ b/src/Propellor/Property/ZFS/Process.hs
@@ -5,7 +5,8 @@
module Propellor.Property.ZFS.Process where
import Propellor.Base
-import Data.String.Utils (split)
+import Utility.Split
+
import Data.List
-- | Gets the properties of a ZFS volume.
diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs
index 27545afb..811ae7f0 100644
--- a/src/Propellor/Shim.hs
+++ b/src/Propellor/Shim.hs
@@ -9,7 +9,6 @@ module Propellor.Shim (setup, cleanEnv, file) where
import Propellor.Base
import Utility.LinuxMkLibs
import Utility.FileMode
-import Utility.FileSystemEncoding
import Data.List
import System.Posix.Files
@@ -57,7 +56,6 @@ shebang = "#!/bin/sh"
checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath
checkAlreadyShimmed f nope = ifM (doesFileExist f)
( withFile f ReadMode $ \h -> do
- fileEncoding h
s <- hGetLine h
if s == shebang
then return f
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index c6699961f..aeaa4643 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -87,12 +87,15 @@ spin' mprivdata relay target hst = do
-- And now we can run it.
unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
- error "remote propellor failed"
+ giveup "remote propellor failed"
where
hn = fromMaybe target relay
sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
+ bootstrapper = case fromInfo (hostInfo hst) of
+ NoInfoVal -> defaultBootstrapper
+ InfoVal bs -> bs
relaying = relay == Just target
viarelay = isJust relay && not relaying
@@ -109,7 +112,7 @@ spin' mprivdata relay target hst = do
updatecmd = intercalate " && "
[ "cd " ++ localdir
- , bootstrapPropellorCommand sys
+ , bootstrapPropellorCommand bootstrapper sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
@@ -169,7 +172,7 @@ getSshTarget target hst
warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
return ip
- configips = map fromIPAddr $ mapMaybe getIPAddr $
+ configips = map val $ mapMaybe getIPAddr $
S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
@@ -186,26 +189,8 @@ update forhost = do
writeFileProtected privfile
whenM hasGitRepo $
- req NeedGitPush gitPushMarker $ \_ -> do
- hin <- dup stdInput
- hout <- dup stdOutput
- hClose stdin
- hClose stdout
- -- Not using git pull because git 2.5.0 badly
- -- broke its option parser.
- unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
- errorMessage "git fetch from client failed"
- unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
- errorMessage "git merge from client failed"
+ gitPullFromUpdateServer
where
- pullparams hin hout =
- [ Param "fetch"
- , Param "--progress"
- , Param "--upload-pack"
- , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
- , Param "."
- ]
-
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
@@ -336,31 +321,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
, "rm -f " ++ remotetarball
]
--- Shim for git push over the propellor ssh channel.
--- Reads from stdin and sends it to hout;
--- reads from hin and sends it to stdout.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
- where
- fromstdin = do
- h <- fdToHandle hout
- connect stdin h
- tostdout = do
- h <- fdToHandle hin
- connect h stdout
- connect fromh toh = do
- hSetBinaryMode fromh True
- hSetBinaryMode toh True
- b <- B.hGetSome fromh 40960
- if B.null b
- then do
- hClose fromh
- hClose toh
- else do
- B.hPut toh b
- hFlush toh
- connect fromh toh
-
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
@@ -388,3 +348,68 @@ findLastNonSpinCommit = do
spinCommitMessage :: String
spinCommitMessage = "propellor spin"
+
+-- Stdin and stdout are connected to the updateServer over ssh.
+-- Request that it run git upload-pack, and connect that up to a git fetch
+-- to receive the data.
+gitPullFromUpdateServer :: IO ()
+gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do
+ -- IO involving stdin can cause data to be buffered in the Handle
+ -- (even when it's set NoBuffering), but we need to pass a FD to
+ -- git fetch containing all of stdin after the gitPushMarker,
+ -- including any that has been buffered.
+ --
+ -- To do so, create a pipe, and forward stdin, including any
+ -- buffered part, through it.
+ (pread, pwrite) <- System.Posix.IO.createPipe
+ -- Note that there is a race between the createPipe and setting
+ -- CloseOnExec. Another processess forked here would inherit
+ -- pwrite and perhaps keep it open. However, propellor is not
+ -- running concurrent threads at this point, so this is ok.
+ setFdOption pwrite CloseOnExec True
+ hwrite <- fdToHandle pwrite
+ forwarder <- async $ stdin *>* hwrite
+ let hin = pread
+ hout <- dup stdOutput
+ hClose stdout
+ -- Not using git pull because git 2.5.0 badly
+ -- broke its option parser.
+ unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
+ errorMessage "git fetch from client failed"
+ wait forwarder
+ unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
+ errorMessage "git merge from client failed"
+ where
+ fetchparams hin hout =
+ [ Param "fetch"
+ , Param "--progress"
+ , Param "--upload-pack"
+ , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+ , Param "."
+ ]
+
+-- Shim for git push over the propellor ssh channel.
+-- Reads from stdin and sends it to hout;
+-- reads from hin and sends it to stdout.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+ where
+ fromstdin = do
+ h <- fdToHandle hout
+ stdin *>* h
+ tostdout = do
+ h <- fdToHandle hin
+ h *>* stdout
+
+-- Forward data from one handle to another.
+(*>*) :: Handle -> Handle -> IO ()
+fromh *>* toh = do
+ b <- B.hGetSome fromh 40960
+ if B.null b
+ then do
+ hClose fromh
+ hClose toh
+ else do
+ B.hPut toh b
+ hFlush toh
+ fromh *>* toh
diff --git a/src/Propellor/Ssh.hs b/src/Propellor/Ssh.hs
index a7a9452e..a8f50ed0 100644
--- a/src/Propellor/Ssh.hs
+++ b/src/Propellor/Ssh.hs
@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
import Data.Time.Clock.POSIX
-import qualified Data.Hash.MD5 as MD5
+import Data.Hashable
-- Parameters can be passed to both ssh and scp, to enable a ssh connection
-- caching socket.
@@ -50,24 +50,22 @@ sshCachingParams hn = do
-- 100 bytes. Try to never construct a filename longer than that.
--
-- When space allows, include the full hostname in the socket filename.
--- Otherwise, include at least a partial md5sum of it,
--- to avoid using the same socket file for multiple hosts.
+-- Otherwise, a checksum of the hostname is included in the name, to
+-- avoid using the same socket file for multiple hosts.
socketFile :: FilePath -> HostName -> FilePath
socketFile home hn = selectSocketFile
- [ sshdir </> hn ++ ".sock"
+ [ sshdir </> hn ++ ".sock"
, sshdir </> hn
- , sshdir </> take 10 hn ++ "-" ++ md5
- , sshdir </> md5
- , home </> ".propellor-" ++ md5
+ , sshdir </> take 10 hn ++ "-" ++ checksum
+ , sshdir </> checksum
]
- (".propellor-" ++ md5)
+ (home </> ".propellor-" ++ checksum)
where
sshdir = home </> ".ssh" </> "propellor"
- md5 = take 9 $ MD5.md5s $ MD5.Str hn
+ checksum = take 9 $ show $ abs $ hash hn
selectSocketFile :: [FilePath] -> FilePath -> FilePath
selectSocketFile [] d = d
-selectSocketFile [f] _ = f
selectSocketFile (f:fs) d
| valid_unix_socket_path f = f
| otherwise = selectSocketFile fs d
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 6d6b14ea..b7c7c7f7 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -12,6 +12,7 @@ module Propellor.Types (
Host(..)
, Property(..)
, property
+ , property''
, Desc
, RevertableProperty(..)
, (<!>)
@@ -24,6 +25,7 @@ module Propellor.Types (
, DebianLike
, Debian
, Buntish
+ , ArchLinux
, FreeBSD
, HasInfo
, type (+)
@@ -35,16 +37,20 @@ module Propellor.Types (
, adjustPropertySatisfy
-- * Other included types
, module Propellor.Types.OS
+ , module Propellor.Types.ConfigurableValue
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
) where
import Data.Monoid
+import Control.Applicative
+import Prelude
import Propellor.Types.Core
import Propellor.Types.Info
import Propellor.Types.OS
+import Propellor.Types.ConfigurableValue
import Propellor.Types.Dns
import Propellor.Types.Result
import Propellor.Types.MetaTypes
@@ -53,7 +59,6 @@ import Propellor.Types.ZFS
-- | The core data type of Propellor, this represents a property
-- that the system should have, with a descrition, and an action to ensure
-- it has the property.
--- that have the property.
--
-- There are different types of properties that target different OS's,
-- and so have different metatypes.
@@ -64,7 +69,7 @@ import Propellor.Types.ZFS
--
-- There are many associated type families, which are mostly used
-- internally, so you needn't worry about them.
-data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
+data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty]
instance Show (Property metatypes) where
show p = "property " ++ show (getDesc p)
@@ -87,14 +92,25 @@ property
=> Desc
-> Propellor Result
-> Property (MetaTypes metatypes)
-property d a = Property sing d a mempty mempty
+property d a = Property sing d (Just a) mempty mempty
+
+property''
+ :: SingI metatypes
+ => Desc
+ -> Maybe (Propellor Result)
+ -> Property (MetaTypes metatypes)
+property'' d a = Property sing d a mempty mempty
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
-adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
+adjustPropertySatisfy (Property t d s i c) f = Property t d (f <$> s) i c
-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
+--
+-- See `Propellor.Property.Versioned.Versioned`
+-- for a way to use RevertableProperty to define different
+-- versions of a host.
data RevertableProperty setupmetatypes undometatypes = RevertableProperty
{ setupRevertableProperty :: Property setupmetatypes
, undoRevertableProperty :: Property undometatypes
@@ -145,7 +161,7 @@ type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Re
type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y))
-type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result
+type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result)
class Combines x y where
-- | Combines together two properties, yielding a property that
@@ -195,3 +211,35 @@ class TightenTargets p where
instance TightenTargets Property where
tightenTargets (Property _ d a i c) = Property sing d a i c
+
+-- | Any type of Property is a monoid. When properties x and y are
+-- appended together, the resulting property has a description like
+-- "x and y". Note that when x fails to be ensured, it will not
+-- try to ensure y.
+instance SingI metatypes => Monoid (Property (MetaTypes metatypes))
+ where
+ mempty = Property sing "noop property" Nothing mempty mempty
+ mappend (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) =
+ Property sing d (a1 <> a2) (i1 <> i2) (c1 <> c2)
+ where
+ -- Avoid including "noop property" in description
+ -- when using eg mconcat.
+ d = case (a1, a2) of
+ (Just _, Just _) -> d1 <> " and " <> d2
+ (Just _, Nothing) -> d1
+ (Nothing, Just _) -> d2
+ (Nothing, Nothing) -> d1
+
+-- | Any type of RevertableProperty is a monoid. When revertable
+-- properties x and y are appended together, the resulting revertable
+-- property has a description like "x and y".
+-- Note that when x fails to be ensured, it will not try to ensure y.
+instance
+ ( Monoid (Property setupmetatypes)
+ , Monoid (Property undometatypes)
+ )
+ => Monoid (RevertableProperty setupmetatypes undometatypes)
+ where
+ mempty = RevertableProperty mempty mempty
+ mappend (RevertableProperty s1 u1) (RevertableProperty s2 u2) =
+ RevertableProperty (s1 <> s2) (u2 <> u1)
diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs
new file mode 100644
index 00000000..4a75503a
--- /dev/null
+++ b/src/Propellor/Types/Bootloader.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-}
+
+module Propellor.Types.Bootloader where
+
+import Propellor.Types.Info
+
+-- | Boot loader installed on a host.
+data BootloaderInstalled = GrubInstalled
+ deriving (Typeable, Show)
+
+instance IsInfo [BootloaderInstalled] where
+ propagateInfo _ = PropagateInfo False
diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs
index fc049603..da912120 100644
--- a/src/Propellor/Types/Chroot.hs
+++ b/src/Propellor/Types/Chroot.hs
@@ -16,7 +16,7 @@ data ChrootInfo = ChrootInfo
deriving (Show, Typeable)
instance IsInfo ChrootInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid ChrootInfo where
mempty = ChrootInfo mempty mempty
diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs
index 558c6e8b..d712a456 100644
--- a/src/Propellor/Types/CmdLine.hs
+++ b/src/Propellor/Types/CmdLine.hs
@@ -28,4 +28,5 @@ data CmdLine
| ChrootChain HostName FilePath Bool Bool
| GitPush Fd Fd
| Check
+ | Build
deriving (Read, Show, Eq)
diff --git a/src/Propellor/Types/ConfigurableValue.hs b/src/Propellor/Types/ConfigurableValue.hs
new file mode 100644
index 00000000..1414be5f
--- /dev/null
+++ b/src/Propellor/Types/ConfigurableValue.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+module Propellor.Types.ConfigurableValue where
+
+import Data.Word
+
+-- | A value that can be used in a configuration file, or otherwise used to
+-- configure a program.
+--
+-- Unlike Show, there should only be instances of this type class for
+-- values that have a standard serialization that is understood outside of
+-- Haskell code.
+--
+-- When converting a type alias such as "type Foo = String" or "type Foo = Int"
+-- to a newtype, it's unsafe to derive a Show instance, because there may
+-- be code that shows the type to configure a value. Instead, define a
+-- ConfigurableValue instance.
+class ConfigurableValue t where
+ val :: t -> String
+
+-- | val String does not do any quoting, unlike show String
+instance ConfigurableValue String where
+ val = id
+
+instance ConfigurableValue Int where
+ val = show
+
+instance ConfigurableValue Integer where
+ val = show
+
+instance ConfigurableValue Float where
+ val = show
+
+instance ConfigurableValue Double where
+ val = show
+
+instance ConfigurableValue Word8 where
+ val = show
+
+instance ConfigurableValue Word16 where
+ val = show
+
+instance ConfigurableValue Word32 where
+ val = show
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
index 6fedc47e..a805f561 100644
--- a/src/Propellor/Types/Core.hs
+++ b/src/Propellor/Types/Core.hs
@@ -48,9 +48,10 @@ instance LiftPropellor Propellor where
instance LiftPropellor IO where
liftPropellor = liftIO
+-- | When two actions are appended together, the second action
+-- is only run if the first action does not fail.
instance Monoid (Propellor Result) where
mempty = return NoChange
- -- | The second action is only run if the first action does not fail.
mappend x y = do
rx <- x
case rx of
@@ -71,7 +72,7 @@ data Props metatypes = Props [ChildProperty]
-- | Since there are many different types of Properties, they cannot be put
-- into a list. The simplified ChildProperty can be put into a list.
-data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
+data ChildProperty = ChildProperty Desc (Maybe (Propellor Result)) Info [ChildProperty]
instance Show ChildProperty where
show p = "property " ++ show (getDesc p)
@@ -92,7 +93,7 @@ class IsProp p where
-- | Gets the action that can be run to satisfy a Property.
-- You should never run this action directly. Use
-- 'Propellor.EnsureProperty.ensureProperty` instead.
- getSatisfy :: p -> Propellor Result
+ getSatisfy :: p -> Maybe (Propellor Result)
instance IsProp ChildProperty where
setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 8f15d156..87756d81 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -5,12 +5,13 @@ module Propellor.Types.Dns where
import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
import Propellor.Types.Info
+import Propellor.Types.ConfigurableValue
+import Utility.Split
import Data.Word
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-import Data.String.Utils (split, replace)
import Data.Monoid
import Prelude
@@ -19,15 +20,15 @@ type Domain = String
data IPAddr = IPv4 String | IPv6 String
deriving (Read, Show, Eq, Ord)
-fromIPAddr :: IPAddr -> String
-fromIPAddr (IPv4 addr) = addr
-fromIPAddr (IPv6 addr) = addr
+instance ConfigurableValue IPAddr where
+ val (IPv4 addr) = addr
+ val (IPv6 addr) = addr
newtype AliasesInfo = AliasesInfo (S.Set HostName)
deriving (Show, Eq, Ord, Monoid, Typeable)
instance IsInfo AliasesInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
toAliasesInfo :: [HostName] -> AliasesInfo
toAliasesInfo l = AliasesInfo (S.fromList l)
@@ -44,7 +45,7 @@ toDnsInfo = DnsInfo
-- | DNS Info is propagated, so that eg, aliases of a container
-- are reflected in the dns for the host where it runs.
instance IsInfo DnsInfo where
- propagateInfo _ = True
+ propagateInfo _ = PropagateInfo True
-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
@@ -101,14 +102,14 @@ data Record
type ReverseIP = String
reverseIP :: IPAddr -> ReverseIP
-reverseIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa"
-reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonicalIP addr) ++ ".ip6.arpa"
+reverseIP (IPv4 addr) = intercalate "." (reverse $ splitc '.' addr) ++ ".in-addr.arpa"
+reverseIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ val $ canonicalIP addr) ++ ".ip6.arpa"
-- | Converts an IP address (particularly IPv6) to canonical, fully
-- expanded form.
canonicalIP :: IPAddr -> IPAddr
canonicalIP (IPv4 addr) = IPv4 addr
-canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr
+canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ splitc ':' $ replaceImplicitGroups addr
where
canonicalGroup g
| l <= 4 = replicate (4 - l) '0' ++ g
@@ -116,7 +117,7 @@ canonicalIP (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":
where
l = length g
emptyGroups n = iterate (++ ":") "" !! n
- numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a)
+ numberOfImplicitGroups a = 8 - length (splitc ':' $ replace "::" "" a)
replaceImplicitGroups a = concat $ aux $ split "::" a
where
aux [] = []
@@ -156,7 +157,7 @@ newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
deriving (Eq, Ord, Show, Typeable)
instance IsInfo NamedConfMap where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
-- | Adding a Master NamedConf stanza for a particulr domain always
-- overrides an existing Secondary stanza for that domain, while a
diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs
index f3cc4a52..6ff340e5 100644
--- a/src/Propellor/Types/Docker.hs
+++ b/src/Propellor/Types/Docker.hs
@@ -16,7 +16,7 @@ data DockerInfo = DockerInfo
deriving (Show, Typeable)
instance IsInfo DockerInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid DockerInfo where
mempty = DockerInfo mempty mempty
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index 2e188ae5..6716c403 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -1,13 +1,14 @@
{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Propellor.Types.Info (
- Info,
+ Info(..),
+ InfoEntry(..),
IsInfo(..),
+ PropagateInfo(..),
addInfo,
toInfo,
fromInfo,
mapInfo,
- propagatableInfo,
InfoVal(..),
fromInfoVal,
Typeable,
@@ -16,6 +17,7 @@ module Propellor.Types.Info (
import Data.Dynamic
import Data.Maybe
import Data.Monoid
+import qualified Data.Typeable as T
import Prelude
-- | Information about a Host, which can be provided by its properties.
@@ -34,7 +36,7 @@ instance Show InfoEntry where
-- Extracts the value from an InfoEntry but only when
-- it's of the requested type.
extractInfoEntry :: Typeable v => InfoEntry -> Maybe v
-extractInfoEntry (InfoEntry v) = cast v
+extractInfoEntry (InfoEntry v) = T.cast v
-- | Values stored in Info must be members of this class.
--
@@ -44,7 +46,13 @@ extractInfoEntry (InfoEntry v) = cast v
class (Typeable v, Monoid v, Show v) => IsInfo v where
-- | Should info of this type be propagated out of a
-- container to its Host?
- propagateInfo :: v -> Bool
+ propagateInfo :: v -> PropagateInfo
+
+data PropagateInfo
+ = PropagateInfo Bool
+ | PropagatePrivData
+ -- ^ Info about PrivData generally will be propigated even in cases
+ -- where other Info is not, so it treated specially.
-- | Any value in the `IsInfo` type class can be added to an Info.
addInfo :: IsInfo v => Info -> v -> Info
@@ -68,11 +76,6 @@ mapInfo f (Info l) = Info (map go l)
Nothing -> i
Just v -> InfoEntry (f v)
--- | Filters out parts of the Info that should not propagate out of a
--- container.
-propagatableInfo :: Info -> Info
-propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l)
-
-- | Use this to put a value in Info that is not a monoid.
-- The last value set will be used. This info does not propagate
-- out of a container.
@@ -85,7 +88,7 @@ instance Monoid (InfoVal v) where
mappend v NoInfoVal = v
instance (Typeable v, Show v) => IsInfo (InfoVal v) where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
fromInfoVal :: InfoVal v -> Maybe v
fromInfoVal NoInfoVal = Nothing
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index e064d76f..19d1998e 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -7,6 +7,7 @@ module Propellor.Types.MetaTypes (
DebianLike,
Debian,
Buntish,
+ ArchLinux,
FreeBSD,
HasInfo,
MetaTypes,
@@ -35,14 +36,26 @@ data MetaType
deriving (Show, Eq, Ord)
-- | Any unix-like system
-type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ]
+type UnixLike = MetaTypes
+ '[ 'Targeting 'OSDebian
+ , 'Targeting 'OSBuntish
+ , 'Targeting 'OSArchLinux
+ , 'Targeting 'OSFreeBSD
+ ]
+
-- | Any linux system
-type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
+type Linux = MetaTypes
+ '[ 'Targeting 'OSDebian
+ , 'Targeting 'OSBuntish
+ , 'Targeting 'OSArchLinux
+ ]
+
-- | Debian and derivatives.
type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
type Debian = MetaTypes '[ 'Targeting 'OSDebian ]
type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ]
type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]
+type ArchLinux = MetaTypes '[ 'Targeting 'OSArchLinux ]
-- | Used to indicate that a Property adds Info to the Host where it's used.
type HasInfo = MetaTypes '[ 'WithInfo ]
@@ -58,16 +71,19 @@ data instance Sing (x :: MetaType) where
OSDebianS :: Sing ('Targeting 'OSDebian)
OSBuntishS :: Sing ('Targeting 'OSBuntish)
OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD)
+ OSArchLinuxS :: Sing ('Targeting 'OSArchLinux)
WithInfoS :: Sing 'WithInfo
instance SingI ('Targeting 'OSDebian) where sing = OSDebianS
instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS
instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS
+instance SingI ('Targeting 'OSArchLinux) where sing = OSArchLinuxS
instance SingI 'WithInfo where sing = WithInfoS
instance SingKind ('KProxy :: KProxy MetaType) where
type DemoteRep ('KProxy :: KProxy MetaType) = MetaType
fromSing OSDebianS = Targeting OSDebian
fromSing OSBuntishS = Targeting OSBuntish
fromSing OSFreeBSDS = Targeting OSFreeBSD
+ fromSing OSArchLinuxS = Targeting OSArchLinux
fromSing WithInfoS = WithInfo
-- | Convenience type operator to combine two `MetaTypes` lists.
@@ -186,6 +202,14 @@ type instance EqT 'OSBuntish 'OSDebian = 'False
type instance EqT 'OSBuntish 'OSFreeBSD = 'False
type instance EqT 'OSFreeBSD 'OSDebian = 'False
type instance EqT 'OSFreeBSD 'OSBuntish = 'False
+type instance EqT 'OSArchLinux 'OSArchLinux = 'True
+type instance EqT 'OSArchLinux 'OSDebian = 'False
+type instance EqT 'OSArchLinux 'OSBuntish = 'False
+type instance EqT 'OSArchLinux 'OSFreeBSD = 'False
+type instance EqT 'OSDebian 'OSArchLinux = 'False
+type instance EqT 'OSBuntish 'OSArchLinux = 'False
+type instance EqT 'OSFreeBSD 'OSArchLinux = 'False
+
-- More modern version if the combinatiorial explosion gets too bad later:
--
-- type family Eq (a :: MetaType) (b :: MetaType) where
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index b569a6e8..01d777a4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -18,10 +18,11 @@ module Propellor.Types.OS (
Group(..),
userGroup,
Port(..),
- fromPort,
systemToTargetOS,
) where
+import Propellor.Types.ConfigurableValue
+
import Network.BSD (HostName)
import Data.Typeable
import Data.String
@@ -33,6 +34,7 @@ data System = System Distribution Architecture
data Distribution
= Debian DebianKernel DebianSuite
| Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per <http://joeyh.name/blog/entry/trademark_nonsense/>
+ | ArchLinux
| FreeBSD FreeBSDRelease
deriving (Show, Eq)
@@ -41,12 +43,14 @@ data Distribution
data TargetOS
= OSDebian
| OSBuntish
+ | OSArchLinux
| OSFreeBSD
deriving (Show, Eq, Ord)
systemToTargetOS :: System -> TargetOS
systemToTargetOS (System (Debian _ _) _) = OSDebian
systemToTargetOS (System (Buntish _) _) = OSBuntish
+systemToTargetOS (System (ArchLinux) _) = OSArchLinux
systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD
-- | Most of Debian ports are based on Linux. There also exist hurd-i386,
@@ -55,7 +59,7 @@ data DebianKernel = Linux | KFreeBSD | Hurd
deriving (Show, Eq)
-- | Debian has several rolling suites, and a number of stable releases,
--- such as Stable "jessie".
+-- such as Stable "stretch".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
deriving (Show, Eq)
@@ -72,10 +76,13 @@ instance IsString FBSDVersion where
fromString "9.3-RELEASE" = FBSD093
fromString _ = error "Invalid FreeBSD release"
+instance ConfigurableValue FBSDVersion where
+ val FBSD101 = "10.1-RELEASE"
+ val FBSD102 = "10.2-RELEASE"
+ val FBSD093 = "9.3-RELEASE"
+
instance Show FBSDVersion where
- show FBSD101 = "10.1-RELEASE"
- show FBSD102 = "10.2-RELEASE"
- show FBSD093 = "9.3-RELEASE"
+ show = val
isStable :: DebianSuite -> Bool
isStable (Stable _) = True
@@ -135,15 +142,21 @@ type UserName = String
newtype User = User UserName
deriving (Eq, Ord, Show)
+instance ConfigurableValue User where
+ val (User n) = n
+
newtype Group = Group String
deriving (Eq, Ord, Show)
+instance ConfigurableValue Group where
+ val (Group n) = n
+
-- | Makes a Group with the same name as the User.
userGroup :: User -> Group
userGroup (User u) = Group u
newtype Port = Port Int
- deriving (Eq, Show)
+ deriving (Eq, Ord, Show)
-fromPort :: Port -> String
-fromPort (Port p) = show p
+instance ConfigurableValue Port where
+ val (Port p) = show p
diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs
new file mode 100644
index 00000000..2b0a8787
--- /dev/null
+++ b/src/Propellor/Types/PartSpec.hs
@@ -0,0 +1,66 @@
+-- | Partition specification combinators.
+
+module Propellor.Types.PartSpec where
+
+import Propellor.Base
+import Propellor.Property.Parted.Types
+import Propellor.Property.Mount
+import Propellor.Property.Partition
+
+-- | Specifies a mount point, mount options, and a constructor for a
+-- Partition that determines its size.
+type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t)
+
+-- | Specifies a partition with a given filesystem.
+--
+-- The partition is not mounted anywhere by default; use the combinators
+-- below to configure it.
+partition :: Monoid t => Fs -> PartSpec t
+partition fs = (Nothing, mempty, mkPartition fs, mempty)
+
+-- | Specifies a swap partition of a given size.
+swapPartition :: Monoid t => PartSize -> PartSpec t
+swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)
+
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec t -> FilePath -> PartSpec t
+mountedAt (_, o, p, t) mp = (Just mp, o, p, t)
+
+-- | Specify a fixed size for a partition.
+setSize :: PartSpec t -> PartSize -> PartSpec t
+setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)
+
+-- | Specifies a mount option, such as "noexec"
+mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
+mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)
+
+-- | Mount option to make a partition be remounted readonly when there's an
+-- error accessing it.
+errorReadonly :: MountOpts
+errorReadonly = toMountOpts "errors=remount-ro"
+
+-- | Sets the percent of the filesystem blocks reserved for the super-user.
+--
+-- The default is 5% for ext2 and ext4. Some filesystems may not support
+-- this.
+reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t
+reservedSpacePercentage s percent = adjustp s $ \p ->
+ p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
+
+-- | Sets a flag on the partition.
+setFlag :: PartSpec t -> PartFlag -> PartSpec t
+setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
+
+-- | Makes a MSDOS partition be Extended, rather than Primary.
+extended :: PartSpec t -> PartSpec t
+extended s = adjustp s $ \p -> p { partType = Extended }
+
+adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
+adjustp (mp, o, p, t) f = (mp, o, f . p, t)
+
+adjustt :: PartSpec t -> (t -> t) -> PartSpec t
+adjustt (mp, o, p, t) f = (mp, o, p, f t)
+
+-- | Default partition size when not otherwize specified is 128 MegaBytes.
+defSz :: PartSize
+defSz = MegaBytes 128
diff --git a/src/Propellor/Types/Result.hs b/src/Propellor/Types/Result.hs
index e8510abf..5209094b 100644
--- a/src/Propellor/Types/Result.hs
+++ b/src/Propellor/Types/Result.hs
@@ -24,6 +24,9 @@ instance ToResult Bool where
toResult False = FailedChange
toResult True = MadeChange
+instance ToResult Result where
+ toResult = id
+
-- | Results of actions, with color.
class ActionResult a where
getActionResult :: a -> (String, ColorIntensity, Color)
diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs
index 3ce4b22c..c68f6ba5 100644
--- a/src/Propellor/Types/ZFS.hs
+++ b/src/Propellor/Types/ZFS.hs
@@ -6,9 +6,11 @@
module Propellor.Types.ZFS where
+import Propellor.Types.ConfigurableValue
+import Utility.Split
+
import Data.String
import qualified Data.Set as Set
-import qualified Data.String.Utils as SU
import Data.List
-- | A single ZFS filesystem.
@@ -32,24 +34,27 @@ toPropertyList = Set.foldr (\p l -> l ++ [toPair p]) []
fromPropertyList :: [(String, String)] -> ZFSProperties
fromPropertyList props =
- Set.fromList $ map fromPair props
+ Set.fromList $ map fromPair props
zfsName :: ZFS -> String
zfsName (ZFS (ZPool pool) dataset) = intercalate "/" [pool, show dataset]
+instance ConfigurableValue ZDataset where
+ val (ZDataset paths) = intercalate "/" paths
+
instance Show ZDataset where
- show (ZDataset paths) = intercalate "/" paths
+ show = val
instance IsString ZDataset where
- fromString s = ZDataset $ SU.split "/" s
+ fromString s = ZDataset $ splitc '/' s
instance IsString ZPool where
- fromString p = ZPool p
+ fromString p = ZPool p
class Value a where
- toValue :: a -> String
- fromValue :: (IsString a) => String -> a
- fromValue = fromString
+ toValue :: a -> String
+ fromValue :: (IsString a) => String -> a
+ fromValue = fromString
data ZFSYesNo = ZFSYesNo Bool deriving (Show, Eq, Ord)
data ZFSOnOff = ZFSOnOff Bool deriving (Show, Eq, Ord)
@@ -57,57 +62,57 @@ data ZFSSize = ZFSSize Integer deriving (Show, Eq, Ord)
data ZFSString = ZFSString String deriving (Show, Eq, Ord)
instance Value ZFSYesNo where
- toValue (ZFSYesNo True) = "yes"
- toValue (ZFSYesNo False) = "no"
+ toValue (ZFSYesNo True) = "yes"
+ toValue (ZFSYesNo False) = "no"
instance Value ZFSOnOff where
- toValue (ZFSOnOff True) = "on"
- toValue (ZFSOnOff False) = "off"
+ toValue (ZFSOnOff True) = "on"
+ toValue (ZFSOnOff False) = "off"
instance Value ZFSSize where
- toValue (ZFSSize s) = show s
+ toValue (ZFSSize s) = show s
instance Value ZFSString where
- toValue (ZFSString s) = s
+ toValue (ZFSString s) = s
instance IsString ZFSString where
- fromString = ZFSString
+ fromString = ZFSString
instance IsString ZFSYesNo where
- fromString "yes" = ZFSYesNo True
- fromString "no" = ZFSYesNo False
- fromString _ = error "Not yes or no"
+ fromString "yes" = ZFSYesNo True
+ fromString "no" = ZFSYesNo False
+ fromString _ = error "Not yes or no"
instance IsString ZFSOnOff where
- fromString "on" = ZFSOnOff True
- fromString "off" = ZFSOnOff False
- fromString _ = error "Not on or off"
+ fromString "on" = ZFSOnOff True
+ fromString "off" = ZFSOnOff False
+ fromString _ = error "Not on or off"
data ZFSACLInherit = AIDiscard | AINoAllow | AISecure | AIPassthrough deriving (Show, Eq, Ord)
instance IsString ZFSACLInherit where
- fromString "discard" = AIDiscard
- fromString "noallow" = AINoAllow
- fromString "secure" = AISecure
- fromString "passthrough" = AIPassthrough
- fromString _ = error "Not valid aclpassthrough value"
+ fromString "discard" = AIDiscard
+ fromString "noallow" = AINoAllow
+ fromString "secure" = AISecure
+ fromString "passthrough" = AIPassthrough
+ fromString _ = error "Not valid aclpassthrough value"
instance Value ZFSACLInherit where
- toValue AIDiscard = "discard"
- toValue AINoAllow = "noallow"
- toValue AISecure = "secure"
- toValue AIPassthrough = "passthrough"
+ toValue AIDiscard = "discard"
+ toValue AINoAllow = "noallow"
+ toValue AISecure = "secure"
+ toValue AIPassthrough = "passthrough"
data ZFSACLMode = AMDiscard | AMGroupmask | AMPassthrough deriving (Show, Eq, Ord)
instance IsString ZFSACLMode where
- fromString "discard" = AMDiscard
- fromString "groupmask" = AMGroupmask
- fromString "passthrough" = AMPassthrough
- fromString _ = error "Invalid zfsaclmode"
+ fromString "discard" = AMDiscard
+ fromString "groupmask" = AMGroupmask
+ fromString "passthrough" = AMPassthrough
+ fromString _ = error "Invalid zfsaclmode"
instance Value ZFSACLMode where
- toValue AMDiscard = "discard"
- toValue AMGroupmask = "groupmask"
- toValue AMPassthrough = "passthrough"
+ toValue AMDiscard = "discard"
+ toValue AMGroupmask = "groupmask"
+ toValue AMPassthrough = "passthrough"
data ZFSProperty = Mounted ZFSYesNo
| Mountpoint ZFSString