propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

commit 0dd021cbf14516fe13d69c800ec9c1bd61d79f5b
parent 5ab617a69d2f064652d85805a1316024ae5995bf
Author: rsiddharth <s@ricketyspace.net>
Date:   Sat,  3 Mar 2018 19:50:08 +0000

Merge remote-tracking branch 'upstream/master'

Diffstat:
debian/changelog | 36++++++++++++++++++++++++++++++++++++
doc/README.mdwn | 9+++++----
joeyconfig.hs | 5+----
propellor.cabal | 4+++-
src/Propellor/DotDir.hs | 54++++++++++++++++++++++++++++++++++++++----------------
src/Propellor/EnsureProperty.hs | 1+
src/Propellor/Git.hs | 4++++
src/Propellor/Git/VerifiedBranch.hs | 11++++++++---
src/Propellor/Property/Atomic.hs | 161+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Git.hs | 18++++++++++++++++++
src/Propellor/Property/Openssl.hs | 29+++++++++++++++++++++++++++++
src/Propellor/Property/SiteSpecific/JoeySites.hs | 42++++++++++++++++++++++++++++++++++++++----
src/Propellor/Property/Systemd.hs | 4++--
13 files changed, 344 insertions(+), 34 deletions(-)

diff --git a/debian/changelog b/debian/changelog @@ -1,3 +1,39 @@ +propellor (5.3.3-1) unstable; urgency=medium + + * New upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Mon, 26 Feb 2018 14:46:09 -0700 + +propellor (5.3.3) unstable; urgency=medium + + * Warn again about new upstream version when ~/.propellor was cloned from the + Debian git bundle using an older version of propellor that set up an + upstream remote. + * Avoid crashing if initial fetch from origin fails when spinning a host. + * Added Propllor.Property.Openssl module contributed by contributed by + Félix Sipma. + + -- Joey Hess <id@joeyh.name> Mon, 26 Feb 2018 14:34:37 -0400 + +propellor (5.3.2-1) unstable; urgency=medium + + * New upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Sun, 18 Feb 2018 14:34:00 -0700 + +propellor (5.3.2) unstable; urgency=medium + + * Added Propellor.Property.Atomic, which can make a non-atomic property + that operates on a directory into an atomic property. + (Inspired by Vaibhav Sagar's talk on Functional Devops in a + Dysfunctional World at LCA 2018.) + * Added Git.pulled. + * Systemd.machined: Install systemd-container on Debian + stretch. + Thanks, Sean Whitton + + -- Joey Hess <id@joeyh.name> Sun, 18 Feb 2018 14:31:39 -0400 + propellor (5.3.1-1) unstable; urgency=medium * New upstream release. diff --git a/doc/README.mdwn b/doc/README.mdwn @@ -18,12 +18,10 @@ There is fairly complete which includes many built-in Properties for dealing with [Apt](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apt.html) and -[Apache](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apache.html) -, +[Apache](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Apache.html), [Cron](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cron.html) and -[Commands](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cmd.html) -, +[Commands](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Cmd.html), [Dns](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Dns.html) and [Docker](http://hackage.haskell.org/package/propellor/docs/Propellor-Property-Docker.html), etc. @@ -56,3 +54,6 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask each host becomes tiresome, you can [automate that](http://propellor.branchable.com/automated_spins/). 7. Write some neat new properties and send patches! + +(Want to get your feet wet with propellor before plunging in? +[[try this|forum/Simple_quickstart_without_git__44___SSH__44___GPG]]) diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -27,7 +27,6 @@ import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.LetsEncrypt as LetsEncrypt import qualified Propellor.Property.Locale as Locale import qualified Propellor.Property.Grub as Grub -import qualified Propellor.Property.FlashKernel as FlashKernel import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd @@ -193,9 +192,7 @@ honeybee = host "honeybee.kitenet.net" $ props `mountedAt` "/" `setSize` MegaBytes 8000 ) - & File.hasPrivContentExposed "/etc/flash-kernel/dtbs/sun7i-a20-cubietruck.dtb" - (Context "cubietruck gpio") - `onChange` FlashKernel.flashKernel + & JoeySites.cubieTruckOneWire & Apt.installed ["firmware-brcm80211"] -- Workaround for https://bugs.debian.org/844056 diff --git a/propellor.cabal b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 5.3.1 +Version: 5.3.3 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> @@ -89,6 +89,7 @@ Library Propellor.Property.Apache Propellor.Property.Apt Propellor.Property.Apt.PPA + Propellor.Property.Atomic Propellor.Property.Attic Propellor.Property.Bootstrap Propellor.Property.Borg @@ -139,6 +140,7 @@ Library Propellor.Property.Nginx Propellor.Property.Obnam Propellor.Property.OpenId + Propellor.Property.Openssl Propellor.Property.OS Propellor.Property.Pacman Propellor.Property.Parted diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs @@ -387,13 +387,12 @@ checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do -- into the user's repository, as if fetching from a upstream remote, -- yielding a new upstream/master branch. -- --- If there's no upstream/master, the user is not using the distrepo, --- so do nothing. And, if there's a remote named "upstream", the user --- must have set that up is not using the distrepo, so do nothing. +-- If there's no upstream/master, or the repo is not using the distrepo, +-- do nothing. updateUpstreamMaster :: String -> IO () -updateUpstreamMaster newref = unlessM (hasRemote "upstream") $ do +updateUpstreamMaster newref = do changeWorkingDirectory =<< dotPropellor - go =<< catchMaybeIO getoldrev + go =<< getoldref where go Nothing = return () go (Just oldref) = do @@ -421,19 +420,42 @@ updateUpstreamMaster newref = unlessM (hasRemote "upstream") $ do cleantmprepo warnoutofdate True - getoldrev = takeWhile (/= '\n') - <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] - git = run "git" run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ error $ "Failed to run " ++ cmd ++ " " ++ show ps + -- Get ref that the upstreambranch points to, only when + -- the distrepo is being used. + getoldref = do + mref <- catchMaybeIO $ takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] + case mref of + Just _ -> do + -- Normally there will be no upstream + -- remote when the distrepo is used. + -- Older versions of propellor set up + -- an upstream remote pointing at the + -- distrepo. + ifM (hasRemote "upstream") + ( do + v <- remoteUrl "upstream" + return $ case v of + Just rurl | rurl == distrepo -> mref + _ -> Nothing + , return mref + ) + Nothing -> return mref + +-- And, if there's a remote named "upstream" +-- that does not point at the distrepo, the user must have set that up +-- and is not using the distrepo, so do nothing. warnoutofdate :: Bool -> IO () -warnoutofdate havebranch = do - warningMessage ("** Your ~/.propellor/ is out of date..") - let also s = infoMessage [" " ++ s] - also ("A newer upstream version is available in " ++ distrepo) - if havebranch - then also ("To merge it, run: git merge " ++ upstreambranch) - else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") - also "" +warnoutofdate havebranch = warningMessage $ unlines + [ "** Your ~/.propellor/ is out of date.." + , indent "A newer upstream version is available in " ++ distrepo + , indent $ if havebranch + then "To merge it, run: git merge " ++ upstreambranch + else "To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again." + ] + where + indent s = " " ++ s diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs @@ -8,6 +8,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' , OuterMetaTypesWitness(..) + , Cannot_ensureProperty_WithInfo ) where import Propellor.Types diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs @@ -30,6 +30,10 @@ hasRemote remotename = catchDefaultIO False $ do rs <- lines <$> readProcess "git" ["remote"] return $ remotename `elem` rs +remoteUrl :: String -> IO (Maybe String) +remoteUrl remotename = catchDefaultIO Nothing $ headMaybe . lines + <$> readProcess "git" ["config", "remote." ++ remotename ++ ".url"] + hasGitRepo :: IO Bool hasGitRepo = doesFileExist ".git/HEAD" diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs @@ -30,12 +30,17 @@ verifyOriginBranch originbranch = do -- Returns True if HEAD is changed by fetching and merging from origin. fetchOrigin :: IO Bool fetchOrigin = do + fetched <- actionMessage "Pull from central git repository" $ + boolSystem "git" [Param "fetch"] + if fetched + then mergeOrigin + else return False + +mergeOrigin :: IO Bool +mergeOrigin = do branchref <- getCurrentBranch let originbranch = "origin" </> branchref - void $ actionMessage "Pull from central git repository" $ - boolSystem "git" [Param "fetch"] - oldsha <- getCurrentGitSha1 branchref keyring <- privDataKeyring diff --git a/src/Propellor/Property/Atomic.hs b/src/Propellor/Property/Atomic.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Property.Atomic ( + atomicDirUpdate, + atomicDirSync, + atomicUpdate, + AtomicResourcePair(..), + flipAtomicResourcePair, + SwapAtomicResourcePair, + CheckAtomicResourcePair, +) where + +import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.EnsureProperty +import Propellor.Property.File +import Propellor.Property.Rsync (syncDir) + +import System.Posix.Files + +-- | A pair of resources, one active and one inactive, which can swap +-- positions atomically. +data AtomicResourcePair a = AtomicResourcePair + { activeAtomicResource :: a + , inactiveAtomicResource :: a + } + +flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a +flipAtomicResourcePair a = AtomicResourcePair + { activeAtomicResource = inactiveAtomicResource a + , inactiveAtomicResource = activeAtomicResource a + } + +-- | Action that activates the inactiveAtomicResource, and deactivates +-- the activeAtomicResource. This action must be fully atomic. +type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor Bool + +-- | Checks which of the pair of resources is currently active and +-- which is inactive, and puts them in the correct poisition in +-- the AtomicResourcePair. +type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a) + +-- | Makes a non-atomic Property be atomic, by applying it to the +-- inactiveAtomicResource, and if it was successful, +-- atomically activating that resource. +atomicUpdate + -- Constriaints inherited from ensureProperty. + :: ( Cannot_ensureProperty_WithInfo t ~ 'True + , (Targets t `NotSuperset` Targets t) ~ 'CanCombine + ) + => SingI t + => AtomicResourcePair a + -> CheckAtomicResourcePair a + -> SwapAtomicResourcePair a + -> (a -> Property (MetaTypes t)) + -> Property (MetaTypes t) +atomicUpdate rbase rcheck rswap mkp = property' d $ \w -> do + r <- rcheck rbase + res <- ensureProperty w $ mkp $ inactiveAtomicResource r + case res of + FailedChange -> return FailedChange + NoChange -> return NoChange + MadeChange -> do + ok <- rswap r + if ok + then return res + else return FailedChange + where + d = getDesc $ mkp $ activeAtomicResource rbase + +-- | Applies a Property to a directory such that the directory is updated +-- fully atomically; there is no point in time in which the directory will +-- be in an inconsistent state. +-- +-- For example, git repositories are not usually updated atomically, +-- and so while the repository is being updated, the files in it can be a +-- mixture of two different versions, which could cause unexpected +-- behavior to consumers. To avoid such problems: +-- +-- > & atomicDirUpdate "/srv/web/example.com" +-- > (\d -> Git.pulled "joey" "http://.." d Nothing) +-- +-- This operates by making a second copy of the directory, and passing it +-- to the Property, which can make whatever changes it needs to that copy, +-- non-atomically. After the Property successfully makes a change, the +-- copy is swapped into place, fully atomically. +-- +-- This necessarily uses double the disk space, since there are two copies +-- of the directory. The parent directory will actually contain three +-- children: a symlink with the name of the directory itself, and two copies +-- of the directory, with names suffixed with ".1" and ".2" +atomicDirUpdate + -- Constriaints inherited from ensureProperty. + :: ( Cannot_ensureProperty_WithInfo t ~ 'True + , (Targets t `NotSuperset` Targets t) ~ 'CanCombine + ) + => SingI t + => FilePath + -> (FilePath -> Property (MetaTypes t)) + -> Property (MetaTypes t) +atomicDirUpdate d = atomicUpdate (mkDirLink d) (checkDirLink d) (swapDirLink d) + +mkDirLink :: FilePath -> AtomicResourcePair FilePath +mkDirLink d = AtomicResourcePair + { activeAtomicResource = addext ".1" + , inactiveAtomicResource = addext ".2" + } + where + addext = addExtension (dropTrailingPathSeparator d) + +inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath +inactiveLinkTarget = takeFileName . inactiveAtomicResource + +swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath +swapDirLink d rp = liftIO $ do + v <- tryIO $ createSymbolicLink (inactiveLinkTarget rp) + `viaStableTmp` d + case v of + Right () -> return True + Left e -> do + warningMessage $ "Unable to update symlink at " ++ d ++ " (" ++ show e ++ ")" + return False + +checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath +checkDirLink d rp = liftIO $ do + v <- tryIO $ readSymbolicLink d + return $ case v of + Right t | t == inactiveLinkTarget rp -> + flipAtomicResourcePair rp + _ -> rp + +-- | This can optionally be used after atomicDirUpdate to rsync the changes +-- that were made over to the other copy of the directory. It's not +-- necessary to use this, but it can improve efficiency. +-- +-- For example: +-- +-- > & atomicDirUpdate "/srv/web/example.com" +-- > (\d -> Git.pulled "joey" "http://.." d Nothing) +-- > `onChange` atomicDirSync "/srv/web/example.com" +-- +-- Using atomicDirSync in the above example lets git only download +-- the changes once, rather than the same changes being downloaded a second +-- time to update the other copy of the directory the next time propellor +-- runs. +-- +-- Suppose that a web server program is run from the git repository, +-- and needs to be restarted after the pull. That restart should be done +-- after the atomicDirUpdate, but before the atomicDirSync. That way, +-- the old web server process will not have its files changed out from +-- under it. +-- +-- > & atomicDirUpdate "/srv/web/example.com" +-- > (\d -> Git.pulled "joey" "http://.." d Nothing) +-- > `onChange` (webServerRestart `before` atomicDirSync "/srv/web/example.com") +atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux) +atomicDirSync d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp) + where + rp = mkDirLink d diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs @@ -61,6 +61,9 @@ type Branch = String -- it will be recursively deleted first. -- -- A branch can be specified, to check out. +-- +-- Does not make subsequent changes be pulled into the repository after +-- it's cloned. cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike cloned owner url dir mbranch = check originurl go `requires` installed @@ -95,11 +98,26 @@ cloned owner url dir mbranch = check originurl go , Just "git update-server-info" ] +-- | Specified git repository is cloned to the specified directory, +-- and any new commits are pulled into it each time this property runs. +pulled :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike +pulled owner url dir mbranch = go + `requires` cloned owner url dir mbranch + `describe` desc + where + desc = "git pulled " ++ url ++ " to " ++ dir + go = userScriptProperty owner + [ "cd " ++ shellEscape dir + , "git pull" + ] + `changesFile` (dir </> ".git" </> "FETCH_HEAD") + isGitDir :: FilePath -> IO Bool isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir]) data GitShared = Shared Group | SharedAll | NotShared +-- | Sets up a new, empty bare git repository. bareRepo :: FilePath -> User -> GitShared -> Property UnixLike bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ dirExists repo : case gitshared of diff --git a/src/Propellor/Property/Openssl.hs b/src/Propellor/Property/Openssl.hs @@ -0,0 +1,29 @@ +-- | Maintainer: Félix Sipma <felix+propellor@gueux.org> + +module Propellor.Property.Openssl where + +import Propellor.Base +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import Utility.FileMode +import Utility.SafeCommand + + +installed :: Property DebianLike +installed = Apt.installed ["openssl"] + +dhparamsLength :: Int +dhparamsLength = 2048 + +dhparams :: FilePath +dhparams = "/etc/ssl/private/dhparams.pem" + +safeDhparams :: Property DebianLike +safeDhparams = propertyList "safe dhparams" $ props + & File.dirExists (takeDirectory dhparams) + & installed + & check (not <$> doesFileExist dhparams) (createDhparams dhparams dhparamsLength) + +createDhparams :: FilePath -> Int -> Property UnixLike +createDhparams f l = property ("generate new dhparams: " ++ f) $ liftIO $ withUmask 0o0177 $ withFile f WriteMode $ \h -> + cmdResult <$> boolSystem' "openssl" [Param "dhparam", Param (show l)] (\p -> p { std_out = UseHandle h }) diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -541,7 +541,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "smtpd_sasl_security_options = noanonymous" , "smtpd_sasl_local_domain = kitenet.net" - , "# Enable postgrey." + , "# Enable postgrey and sasl auth and client certs." , "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 is not enabled because it causes mails forwarded from eg gmail to be rejected)" @@ -668,7 +668,6 @@ domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb 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` @@ -680,6 +679,9 @@ postfixSaslPasswordClient = combineProperties "postfix uses SASL password to aut , "smtp_sasl_password_maps = hash:/etc/postfix/sasl_passwd" ] `onChange` Postfix.reloaded + -- Comes after so it does not set relayhost but uses the setting + -- above. + & Postfix.satellite hasPostfixCert :: Context -> Property (HasInfo + UnixLike) hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props @@ -1048,7 +1050,7 @@ laptopSoftware = Apt.installed , "ttf-bitstream-vera" , "mairix", "offlineimap", "mutt" , "nmap", "whois", "wireshark", "tcpdump", "iftop" - , "udevil", "pmount", "tree" + , "udevil", "pmount", "tree", "pv" , "arbtt", "hledger", "bc" , "apache2", "ikiwiki", "libhighlight-perl" , "pal" @@ -1059,7 +1061,7 @@ laptopSoftware = Apt.installed , "vim-syntastic", "vim-fugitive" , "adb", "gthumb" , "w3m", "sm", "weechat" - , "borgbackup", "wipe" + , "borgbackup", "wipe", "smartmontools", "libgfshare-bin" , "units" ] `requires` baseSoftware @@ -1079,3 +1081,35 @@ devSoftware = Apt.installed , "gdb", "dpkg-repack", "lintian" , "pristine-tar", "github-backup" ] + +cubieTruckOneWire :: Property DebianLike +cubieTruckOneWire = + File.hasContent "/etc/easy-peasy-devicetree-squeezy/my.dts" mydts + `onChange` utilitysetup + `requires` utilityinstalled + where + utilityinstalled = Git.cloned (User "root") "https://git.joeyh.name/git/easy-peasy-devicetree-squeezy.git" "/usr/local/easy-peasy-devicetree-squeezy" Nothing + `onChange` File.isSymlinkedTo "/usr/local/bin/easy-peasy-devicetree-squeezy" (File.LinkTarget "/usr/local/easy-peasy-devicetree-squeezy/easy-peasy-devicetree-squeezy") + utilitysetup = cmdProperty "easy-peasy-devicetree-squeezy" + ["--debian", "sun7i-a20-cubietruck"] + `assume` MadeChange + mydts = + [ "/* Device tree addition enabling onewire sensors on CubieTruck GPIO pin PG8 */" + , "#include <dt-bindings/gpio/gpio.h>" + , "" + , "/ {" + , "\tonewire_device {" + , "\t\tcompatible = \"w1-gpio\";" + , "\t\tgpios = <&pio 6 8 GPIO_ACTIVE_HIGH>; /* PG8 */" + , "\t\tpinctrl-names = \"default\";" + , "\t\tpinctrl-0 = <&my_w1_pin>;" + , "\t};" + , "};" + , "" + , "&pio {" + , "\tmy_w1_pin: my_w1_pin@0 {" + , "\t\tallwinner,pins = \"PG8\";" + , "\t\tallwinner,function = \"gpio_in\";" + , "\t};" + , "};" + ] diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs @@ -205,8 +205,8 @@ machined = withOS "machined installed" $ \w o -> case o of -- Split into separate debian package since systemd 225. (Just (System (Debian _ suite) _)) - | not (isStable suite) -> ensureProperty w $ - Apt.installed ["systemd-container"] + | not (isStable suite) || suite == (Stable "stretch") -> + ensureProperty w $ Apt.installed ["systemd-container"] _ -> noChange -- | Defines a container with a given machine name,