From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- src/Propellor/Property/Apache.hs | 62 +++ src/Propellor/Property/Apt.hs | 256 ++++++++++++ src/Propellor/Property/Cmd.hs | 49 +++ src/Propellor/Property/Cron.hs | 49 +++ src/Propellor/Property/Dns.hs | 405 ++++++++++++++++++ src/Propellor/Property/Docker.hs | 456 +++++++++++++++++++++ src/Propellor/Property/Docker/Shim.hs | 61 +++ src/Propellor/Property/File.hs | 94 +++++ src/Propellor/Property/Git.hs | 93 +++++ src/Propellor/Property/Gpg.hs | 41 ++ src/Propellor/Property/Hostname.hs | 33 ++ src/Propellor/Property/Network.hs | 30 ++ src/Propellor/Property/Obnam.hs | 155 +++++++ src/Propellor/Property/OpenId.hs | 29 ++ src/Propellor/Property/Postfix.hs | 25 ++ src/Propellor/Property/Reboot.hs | 7 + src/Propellor/Property/Scheduled.hs | 67 +++ src/Propellor/Property/Service.hs | 31 ++ .../Property/SiteSpecific/GitAnnexBuilder.hs | 57 +++ src/Propellor/Property/SiteSpecific/GitHome.hs | 34 ++ src/Propellor/Property/SiteSpecific/JoeySites.hs | 314 ++++++++++++++ src/Propellor/Property/Ssh.hs | 152 +++++++ src/Propellor/Property/Sudo.hs | 32 ++ src/Propellor/Property/Tor.hs | 19 + src/Propellor/Property/User.hs | 61 +++ 25 files changed, 2612 insertions(+) create mode 100644 src/Propellor/Property/Apache.hs create mode 100644 src/Propellor/Property/Apt.hs create mode 100644 src/Propellor/Property/Cmd.hs create mode 100644 src/Propellor/Property/Cron.hs create mode 100644 src/Propellor/Property/Dns.hs create mode 100644 src/Propellor/Property/Docker.hs create mode 100644 src/Propellor/Property/Docker/Shim.hs create mode 100644 src/Propellor/Property/File.hs create mode 100644 src/Propellor/Property/Git.hs create mode 100644 src/Propellor/Property/Gpg.hs create mode 100644 src/Propellor/Property/Hostname.hs create mode 100644 src/Propellor/Property/Network.hs create mode 100644 src/Propellor/Property/Obnam.hs create mode 100644 src/Propellor/Property/OpenId.hs create mode 100644 src/Propellor/Property/Postfix.hs create mode 100644 src/Propellor/Property/Reboot.hs create mode 100644 src/Propellor/Property/Scheduled.hs create mode 100644 src/Propellor/Property/Service.hs create mode 100644 src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs create mode 100644 src/Propellor/Property/SiteSpecific/GitHome.hs create mode 100644 src/Propellor/Property/SiteSpecific/JoeySites.hs create mode 100644 src/Propellor/Property/Ssh.hs create mode 100644 src/Propellor/Property/Sudo.hs create mode 100644 src/Propellor/Property/Tor.hs create mode 100644 src/Propellor/Property/User.hs (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs new file mode 100644 index 00000000..cf3e62cc --- /dev/null +++ b/src/Propellor/Property/Apache.hs @@ -0,0 +1,62 @@ +module Propellor.Property.Apache where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +type ConfigFile = [String] + +siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled hn cf = RevertableProperty enable disable + where + enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn] + `describe` ("apache site enabled " ++ hn) + `requires` siteAvailable hn cf + `requires` installed + `onChange` reloaded + disable = trivial $ File.notPresent (siteCfg hn) + `describe` ("apache site disabled " ++ hn) + `onChange` cmdProperty "a2dissite" ["--quiet", hn] + `requires` installed + `onChange` reloaded + +siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf) + `describe` ("apache site available " ++ hn) + where + comment = "# deployed with propellor, do not modify" + +modEnabled :: String -> RevertableProperty +modEnabled modname = RevertableProperty enable disable + where + enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname] + `describe` ("apache module enabled " ++ modname) + `requires` installed + `onChange` reloaded + disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname] + `describe` ("apache module disabled " ++ modname) + `requires` installed + `onChange` reloaded + +siteCfg :: HostName -> FilePath +siteCfg hn = "/etc/apache2/sites-available/" ++ hn + +installed :: Property +installed = Apt.installed ["apache2"] + +restarted :: Property +restarted = cmdProperty "service" ["apache2", "restart"] + +reloaded :: Property +reloaded = Service.reloaded "apache2" + +-- | Configure apache to use SNI to differentiate between +-- https hosts. +multiSSL :: Property +multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` + [ "NameVirtualHost *:443" + , "SSLStrictSNIVHostCheck off" + ] + `describe` "apache SNI enabled" + `onChange` reloaded diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs new file mode 100644 index 00000000..7329c7a8 --- /dev/null +++ b/src/Propellor/Property/Apt.hs @@ -0,0 +1,256 @@ +module Propellor.Property.Apt where + +import Data.Maybe +import Control.Applicative +import Data.List +import System.IO +import Control.Monad + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Service as Service +import Propellor.Property.File (Line) + +sourcesList :: FilePath +sourcesList = "/etc/apt/sources.list" + +type Url = String +type Section = String + +type SourcesGenerator = DebianSuite -> [Line] + +showSuite :: DebianSuite -> String +showSuite Stable = "stable" +showSuite Testing = "testing" +showSuite Unstable = "unstable" +showSuite Experimental = "experimental" +showSuite (DebianRelease r) = r + +backportSuite :: String +backportSuite = showSuite stableRelease ++ "-backports" + +debLine :: String -> Url -> [Section] -> Line +debLine suite mirror sections = unwords $ + ["deb", mirror, suite] ++ sections + +srcLine :: Line -> Line +srcLine l = case words l of + ("deb":rest) -> unwords $ "deb-src" : rest + _ -> "" + +stdSections :: [Section] +stdSections = ["main", "contrib", "non-free"] + +binandsrc :: String -> SourcesGenerator +binandsrc url suite + | isStable suite = [l, srcLine l, bl, srcLine bl] + | otherwise = [l, srcLine l] + where + l = debLine (showSuite suite) url stdSections + bl = debLine backportSuite url stdSections + +debCdn :: SourcesGenerator +debCdn = binandsrc "http://cdn.debian.net/debian" + +kernelOrg :: SourcesGenerator +kernelOrg = binandsrc "http://mirrors.kernel.org/debian" + +-- | Only available for Stable and Testing +securityUpdates :: SourcesGenerator +securityUpdates suite + | isStable suite || suite == Testing = + let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections + in [l, srcLine l] + | otherwise = [] + +-- | Makes sources.list have a standard content using the mirror CDN, +-- with a particular DebianSuite. +-- +-- Since the CDN is sometimes unreliable, also adds backup lines using +-- kernel.org. +stdSourcesList :: DebianSuite -> Property +stdSourcesList suite = stdSourcesList' suite [] + +-- | Adds additional sources.list generators. +-- +-- 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 +stdSourcesList' suite more = setSourcesList + (concatMap (\gen -> gen suite) generators) + `describe` ("standard sources.list for " ++ show suite) + where + generators = [debCdn, kernelOrg, securityUpdates] ++ more + +setSourcesList :: [Line] -> Property +setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update + +setSourcesListD :: [Line] -> FilePath -> Property +setSourcesListD ls basename = f `File.hasContent` ls `onChange` update + where + f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" + +runApt :: [String] -> Property +runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv + +noninteractiveEnv :: [(String, String)] +noninteractiveEnv = + [ ("DEBIAN_FRONTEND", "noninteractive") + , ("APT_LISTCHANGES_FRONTEND", "none") + ] + +update :: Property +update = runApt ["update"] + `describe` "apt update" + +upgrade :: Property +upgrade = runApt ["-y", "dist-upgrade"] + `describe` "apt dist-upgrade" + +type Package = String + +installed :: [Package] -> Property +installed = installed' ["-y"] + +installed' :: [String] -> [Package] -> Property +installed' params ps = robustly $ check (isInstallable ps) go + `describe` (unwords $ "apt installed":ps) + where + go = runApt $ params ++ ["install"] ++ ps + +installedBackport :: [Package] -> Property +installedBackport ps = trivial $ withOS desc $ \o -> case o of + Nothing -> error "cannot install backports; os not declared" + (Just (System (Debian suite) _)) + | isStable suite -> + ensureProperty $ runApt $ + ["install", "-t", backportSuite, "-y"] ++ ps + _ -> error $ "backports not supported on " ++ show o + where + desc = (unwords $ "apt installed backport":ps) + +-- | Minimal install of package, without recommends. +installedMin :: [Package] -> Property +installedMin = installed' ["--no-install-recommends", "-y"] + +removed :: [Package] -> Property +removed ps = check (or <$> isInstalled' ps) go + `describe` (unwords $ "apt removed":ps) + where + go = runApt $ ["-y", "remove"] ++ ps + +buildDep :: [Package] -> Property +buildDep ps = robustly go + `describe` (unwords $ "apt build-dep":ps) + where + go = runApt $ ["-y", "build-dep"] ++ ps + +-- | Installs the build deps for the source package unpacked +-- in the specifed directory, with a dummy package also +-- installed so that autoRemove won't remove them. +buildDepIn :: FilePath -> Property +buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] + where + go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] + noninteractiveEnv + +-- | Package installation may fail becuse the archive has changed. +-- Run an update in that case and retry. +robustly :: Property -> Property +robustly p = adjustProperty p $ \satisfy -> do + r <- satisfy + if r == FailedChange + then ensureProperty $ p `requires` update + else return r + +isInstallable :: [Package] -> IO Bool +isInstallable ps = do + l <- isInstalled' ps + return $ any (== False) l && not (null l) + +isInstalled :: Package -> IO Bool +isInstalled p = (== [True]) <$> isInstalled' [p] + +-- | Note that the order of the returned list will not always +-- correspond to the order of the input list. The number of items may +-- even vary. If apt does not know about a package at all, it will not +-- be included in the result list. +isInstalled' :: [Package] -> IO [Bool] +isInstalled' ps = catMaybes . map parse . lines + <$> readProcess "apt-cache" ("policy":ps) + where + parse l + | "Installed: (none)" `isInfixOf` l = Just False + | "Installed: " `isInfixOf` l = Just True + | otherwise = Nothing + +autoRemove :: Property +autoRemove = runApt ["-y", "autoremove"] + `describe` "apt autoremove" + +-- | Enables unattended upgrades. Revert to disable. +unattendedUpgrades :: RevertableProperty +unattendedUpgrades = RevertableProperty enable disable + where + enable = setup True + `before` Service.running "cron" + `before` configure + disable = setup False + + setup enabled = (if enabled then installed else removed) ["unattended-upgrades"] + `onChange` reConfigure "unattended-upgrades" + [("unattended-upgrades/enable_auto_updates" , "boolean", v)] + `describe` ("unattended upgrades " ++ v) + where + v + | enabled = "true" + | otherwise = "false" + + configure = withOS "unattended upgrades configured" $ \o -> + case o of + -- the package defaults to only upgrading stable + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty $ + "/etc/apt/apt.conf.d/50unattended-upgrades" + `File.containsLine` + ("\t\"o=Debian,a="++showSuite suite++"\";") + _ -> noChange + +-- | Preseeds debconf values and reconfigures the package so it takes +-- effect. +reConfigure :: Package -> [(String, String, String)] -> Property +reConfigure package vals = reconfigure `requires` setselections + `describe` ("reconfigure " ++ package) + where + setselections = property "preseed" $ makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "debconf-set-selections" []) $ \h -> do + forM_ vals $ \(tmpl, tmpltype, value) -> + hPutStrLn h $ unwords [package, tmpl, tmpltype, value] + hClose h + reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv + +-- | Ensures that a service is installed and running. +-- +-- Assumes that there is a 1:1 mapping between service names and apt +-- package names. +serviceInstalledRunning :: Package -> Property +serviceInstalledRunning svc = Service.running svc `requires` installed [svc] + +data AptKey = AptKey + { keyname :: String + , pubkey :: String + } + +trustsKey :: AptKey -> RevertableProperty +trustsKey k = RevertableProperty trust untrust + where + desc = "apt trusts key " ++ keyname k + f = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" + untrust = File.notPresent f + trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do + withHandle StdinHandle createProcessSuccess + (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do + hPutStr h (pubkey k) + hClose h + nukeFile $ f ++ "~" -- gpg dropping diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs new file mode 100644 index 00000000..bcd08246 --- /dev/null +++ b/src/Propellor/Property/Cmd.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Property.Cmd ( + cmdProperty, + cmdProperty', + scriptProperty, + userScriptProperty, +) where + +import Control.Applicative +import Data.List +import "mtl" Control.Monad.Reader + +import Propellor.Types +import Propellor.Property +import Utility.Monad +import Utility.SafeCommand +import Utility.Env + +-- | A property that can be satisfied by running a command. +-- +-- The command must exit 0 on success. +cmdProperty :: String -> [String] -> Property +cmdProperty cmd params = cmdProperty' cmd params [] + +-- | A property that can be satisfied by running a command, +-- with added environment. +cmdProperty' :: String -> [String] -> [(String, String)] -> Property +cmdProperty' cmd params env = property desc $ liftIO $ do + env' <- addEntries env <$> getEnvironment + ifM (boolSystemEnv cmd (map Param params) (Just env')) + ( return MadeChange + , return FailedChange + ) + where + desc = unwords $ cmd : params + +-- | A property that can be satisfied by running a series of shell commands. +scriptProperty :: [String] -> Property +scriptProperty script = cmdProperty "sh" ["-c", shellcmd] + where + shellcmd = intercalate " ; " ("set -e" : script) + +-- | A property that can satisfied by running a series of shell commands, +-- as user (cd'd to their home directory). +userScriptProperty :: UserName -> [String] -> Property +userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] + where + shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs new file mode 100644 index 00000000..5b070eff --- /dev/null +++ b/src/Propellor/Property/Cron.hs @@ -0,0 +1,49 @@ +module Propellor.Property.Cron where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import Utility.SafeCommand + +import Data.Char + +type CronTimes = String + +-- | Installs a cron job, run as a specified user, in a particular +-- directory. Note that the Desc must be unique, as it is used for the +-- cron.d/ filename. +-- +-- Only one instance of the cron job is allowed to run at a time, no matter +-- how long it runs. This is accomplished using flock locking of the cron +-- job file. +-- +-- The cron job's output will only be emailed if it exits nonzero. +job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +job desc times user cddir command = cronjobfile `File.hasContent` + [ "# Generated by propellor" + , "" + , "SHELL=/bin/sh" + , "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" + , "" + , times ++ "\t" ++ user ++ "\t" + ++ "chronic flock -n " ++ shellEscape cronjobfile + ++ " sh -c " ++ shellEscape cmdline + ] + `requires` Apt.serviceInstalledRunning "cron" + `requires` Apt.installed ["util-linux", "moreutils"] + `describe` ("cronned " ++ desc) + where + cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" + cronjobfile = "/etc/cron.d/" ++ map sanitize desc + sanitize c + | isAlphaNum c = c + | otherwise = '_' + +-- | Installs a cron job, and runs it niced and ioniced. +niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +niceJob desc times user cddir command = job desc times user cddir + ("nice ionice -c 3 " ++ command) + +-- | Installs a cron job to run propellor. +runPropellor :: CronTimes -> Property +runPropellor times = niceJob "propellor" times "root" localdir "make" diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs new file mode 100644 index 00000000..5c3162cb --- /dev/null +++ b/src/Propellor/Property/Dns.hs @@ -0,0 +1,405 @@ +module Propellor.Property.Dns ( + module Propellor.Types.Dns, + primary, + secondary, + secondaryFor, + mkSOA, + writeZoneFile, + nextSerialNumber, + adjustSerialNumber, + serialNumberOffset, + WarningMessage, + genZone, +) where + +import Propellor +import Propellor.Types.Dns +import Propellor.Property.File +import Propellor.Types.Attr +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Utility.Applicative + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List + +-- | Primary dns server for a domain. +-- +-- Most of the content of the zone file is configured by setting properties +-- of hosts. For example, +-- +-- > host "foo.example.com" +-- > & ipv4 "192.168.1.1" +-- > & alias "mail.exmaple.com" +-- +-- Will cause that hostmame and its alias to appear in the zone file, +-- with the configured IP address. +-- +-- The [(BindDomain, Record)] list can be used for additional records +-- that cannot be configured elsewhere. This often includes NS records, +-- TXT records and perhaps CNAMEs pointing at hosts that propellor does +-- not control. +-- +-- The primary server is configured to only allow zone transfers to +-- secondary dns servers. These are determined in two ways: +-- +-- 1. By looking at the properties of other hosts, to find hosts that +-- are configured as the secondary dns server. +-- +-- 2. By looking for NS Records in the passed list of records. +-- +-- In either case, the secondary dns server Host should have an ipv4 and/or +-- ipv6 property defined. +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +primary hosts domain soa rs = RevertableProperty setup cleanup + where + setup = withwarnings (check needupdate baseprop) + `requires` servingZones + `onChange` Service.reloaded "bind9" + cleanup = check (doesFileExist zonefile) $ + property ("removed dns primary for " ++ domain) + (makeChange $ removeZoneFile zonefile) + `requires` namedConfWritten + `onChange` Service.reloaded "bind9" + + (partialzone, zonewarnings) = genZone hosts domain soa + zone = partialzone { zHosts = zHosts partialzone ++ rs } + zonefile = "/etc/bind/propellor/db." ++ domain + baseprop = Property ("dns primary for " ++ domain) + (makeChange $ writeZoneFile zone zonefile) + (addNamedConf conf) + withwarnings p = adjustProperty p $ \satisfy -> do + mapM_ warningMessage $ zonewarnings ++ secondarywarnings + satisfy + conf = NamedConf + { confDomain = domain + , confDnsServerType = Master + , confFile = zonefile + , confMasters = [] + , confAllowTransfer = nub $ + concatMap (\h -> hostAddresses h hosts) $ + secondaries ++ nssecondaries + , confLines = [] + } + secondaries = otherServers Secondary hosts domain + secondarywarnings = map (\h -> "No IP address defined for DNS seconary " ++ h) $ + filter (\h -> null (hostAddresses h hosts)) secondaries + nssecondaries = mapMaybe (domainHostName <=< getNS) rootRecords + rootRecords = map snd $ + filter (\(d, _r) -> d == RootDomain || d == AbsDomain domain) rs + needupdate = do + v <- readZonePropellorFile zonefile + return $ case v of + Nothing -> True + Just oldzone -> + -- compare everything except serial + let oldserial = sSerial (zSOA oldzone) + z = zone { zSOA = (zSOA zone) { sSerial = oldserial } } + in z /= oldzone || oldserial < sSerial (zSOA zone) + +-- | Secondary dns server for a domain. +-- +-- The primary server is determined by looking at the properties of other +-- hosts to find which one is configured as the primary. +-- +-- Note that if a host is declared to be a primary and a secondary dns +-- server for the same domain, the primary server config always wins. +secondary :: [Host] -> Domain -> RevertableProperty +secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain + +-- | This variant is useful if the primary server does not have its DNS +-- configured via propellor. +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty +secondaryFor masters hosts domain = RevertableProperty setup cleanup + where + setup = pureAttrProperty desc (addNamedConf conf) + `requires` servingZones + cleanup = namedConfWritten + + desc = "dns secondary for " ++ domain + conf = NamedConf + { confDomain = domain + , confDnsServerType = Secondary + , confFile = "db." ++ domain + , confMasters = concatMap (\m -> hostAddresses m hosts) masters + , confAllowTransfer = [] + , confLines = [] + } + +otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] +otherServers wantedtype hosts domain = + M.keys $ M.filter wanted $ hostAttrMap hosts + where + wanted attr = case M.lookup domain (_namedconf attr) of + Nothing -> False + Just conf -> confDnsServerType conf == wantedtype + && confDomain conf == domain + +-- | Rewrites the whole named.conf.local file to serve the zones +-- configured by `primary` and `secondary`, and ensures that bind9 is +-- running. +servingZones :: Property +servingZones = namedConfWritten + `onChange` Service.reloaded "bind9" + `requires` Apt.serviceInstalledRunning "bind9" + +namedConfWritten :: Property +namedConfWritten = property "named.conf configured" $ do + zs <- getNamedConf + ensureProperty $ + hasContent namedConfFile $ + concatMap confStanza $ M.elems zs + +confStanza :: NamedConf -> [Line] +confStanza c = + [ "// automatically generated by propellor" + , "zone \"" ++ confDomain c ++ "\" {" + , cfgline "type" (if confDnsServerType c == Master then "master" else "slave") + , cfgline "file" ("\"" ++ confFile c ++ "\"") + ] ++ + mastersblock ++ + allowtransferblock ++ + (map (\l -> "\t" ++ l ++ ";") (confLines c)) ++ + [ "};" + , "" + ] + where + cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" + ipblock name l = + [ "\t" ++ name ++ " {" ] ++ + (map (\ip -> "\t\t" ++ fromIPAddr ip ++ ";") l) ++ + [ "\t};" ] + mastersblock + | null (confMasters c) = [] + | otherwise = ipblock "masters" (confMasters c) + -- an empty block prohibits any transfers + allowtransferblock = ipblock "allow-transfer" (confAllowTransfer c) + +namedConfFile :: FilePath +namedConfFile = "/etc/bind/named.conf.local" + +-- | Generates a SOA with some fairly sane numbers in it. +-- +-- The Domain is the domain to use in the SOA record. Typically +-- something like ns1.example.com. So, not the domain that this is the SOA +-- record for. +-- +-- The SerialNumber can be whatever serial number was used by the domain +-- before propellor started managing it. Or 0 if the domain has only ever +-- been managed by propellor. +-- +-- You do not need to increment the SerialNumber when making changes! +-- Propellor will automatically add the number of commits in the git +-- repository to the SerialNumber. +mkSOA :: Domain -> SerialNumber -> SOA +mkSOA d sn = SOA + { sDomain = AbsDomain d + , sSerial = sn + , sRefresh = hours 4 + , sRetry = hours 1 + , sExpire = 2419200 -- 4 weeks + , sNegativeCacheTTL = hours 8 + } + where + hours n = n * 60 * 60 + +dValue :: BindDomain -> String +dValue (RelDomain d) = d +dValue (AbsDomain d) = d ++ "." +dValue (RootDomain) = "@" + +rField :: Record -> String +rField (Address (IPv4 _)) = "A" +rField (Address (IPv6 _)) = "AAAA" +rField (CNAME _) = "CNAME" +rField (MX _ _) = "MX" +rField (NS _) = "NS" +rField (TXT _) = "TXT" +rField (SRV _ _ _ _) = "SRV" + +rValue :: Record -> String +rValue (Address (IPv4 addr)) = addr +rValue (Address (IPv6 addr)) = addr +rValue (CNAME d) = dValue d +rValue (MX pri d) = show pri ++ " " ++ dValue d +rValue (NS d) = dValue d +rValue (SRV priority weight port target) = unwords + [ show priority + , show weight + , show port + , dValue target + ] +rValue (TXT s) = [q] ++ filter (/= q) s ++ [q] + where + q = '"' + +-- | Adjusts the serial number of the zone to always be larger +-- than the serial number in the Zone record, +-- and always be larger than the passed SerialNumber. +nextSerialNumber :: Zone -> SerialNumber -> Zone +nextSerialNumber z serial = adjustSerialNumber z $ \sn -> succ $ max sn serial + +adjustSerialNumber :: Zone -> (SerialNumber -> SerialNumber) -> Zone +adjustSerialNumber (Zone d soa l) f = Zone d soa' l + where + soa' = soa { sSerial = f (sSerial soa) } + +-- | Count the number of git commits made to the current branch. +serialNumberOffset :: IO SerialNumber +serialNumberOffset = fromIntegral . length . lines + <$> readProcess "git" ["log", "--pretty=%H"] + +-- | Write a Zone out to a to a file. +-- +-- The serial number in the Zone automatically has the serialNumberOffset +-- added to it. Also, just in case, the old serial number used in the zone +-- file is checked, and if it is somehow larger, its succ is used. +writeZoneFile :: Zone -> FilePath -> IO () +writeZoneFile z f = do + oldserial <- oldZoneFileSerialNumber f + offset <- serialNumberOffset + let z' = nextSerialNumber + (adjustSerialNumber z (+ offset)) + oldserial + createDirectoryIfMissing True (takeDirectory f) + writeFile f (genZoneFile z') + writeZonePropellorFile f z' + +removeZoneFile :: FilePath -> IO () +removeZoneFile f = do + nukeFile f + nukeFile (zonePropellorFile f) + +-- | Next to the zone file, is a ".propellor" file, which contains +-- the serialized Zone. This saves the bother of parsing +-- the horrible bind zone file format. +zonePropellorFile :: FilePath -> FilePath +zonePropellorFile f = f ++ ".propellor" + +oldZoneFileSerialNumber :: FilePath -> IO SerialNumber +oldZoneFileSerialNumber = maybe 0 (sSerial . zSOA) <$$> readZonePropellorFile + +writeZonePropellorFile :: FilePath -> Zone -> IO () +writeZonePropellorFile f z = writeFile (zonePropellorFile f) (show z) + +readZonePropellorFile :: FilePath -> IO (Maybe Zone) +readZonePropellorFile f = catchDefaultIO Nothing $ + readish <$> readFileStrict (zonePropellorFile f) + +-- | Generating a zone file. +genZoneFile :: Zone -> String +genZoneFile (Zone zdomain soa rs) = unlines $ + header : genSOA soa ++ map (genRecord zdomain) rs + where + header = com $ "BIND zone file for " ++ zdomain ++ ". Generated by propellor, do not edit." + +genRecord :: Domain -> (BindDomain, Record) -> String +genRecord zdomain (domain, record) = intercalate "\t" + [ domainHost zdomain domain + , "IN" + , rField record + , rValue record + ] + +genSOA :: SOA -> [String] +genSOA soa = + -- "@ IN SOA ns1.example.com. root (" + [ intercalate "\t" + [ dValue RootDomain + , "IN" + , "SOA" + , dValue (sDomain soa) + , "root" + , "(" + ] + , headerline sSerial "Serial" + , headerline sRefresh "Refresh" + , headerline sRetry "Retry" + , headerline sExpire "Expire" + , headerline sNegativeCacheTTL "Negative Cache TTL" + , inheader ")" + ] + where + headerline r comment = inheader $ show (r soa) ++ "\t\t" ++ com comment + inheader l = "\t\t\t" ++ l + +-- | Comment line in a zone file. +com :: String -> String +com s = "; " ++ s + +type WarningMessage = String + +-- | Generates a Zone for a particular Domain from the DNS properies of all +-- hosts that propellor knows about that are in that Domain. +genZone :: [Host] -> Domain -> SOA -> (Zone, [WarningMessage]) +genZone hosts zdomain soa = + let (warnings, zhosts) = partitionEithers $ concat $ map concat + [ map hostips inzdomain + , map hostrecords inzdomain + , map addcnames (M.elems m) + ] + in (Zone zdomain soa (nub zhosts), warnings) + where + m = hostAttrMap hosts + -- Known hosts with hostname located in the zone's domain. + inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m + + -- Each host with a hostname located in the zdomain + -- should have 1 or more IPAddrs in its Attr. + -- + -- If a host lacks any IPAddr, it's probably a misconfiguration, + -- so warn. + hostips :: Attr -> [Either WarningMessage (BindDomain, Record)] + hostips attr + | null l = [Left $ "no IP address defined for host " ++ _hostname attr] + | otherwise = map Right l + where + l = zip (repeat $ AbsDomain $ _hostname attr) + (map Address $ getAddresses attr) + + -- Any host, whether its hostname is in the zdomain or not, + -- may have cnames which are in the zdomain. The cname may even be + -- the same as the root of the zdomain, which is a nice way to + -- specify IP addresses for a SOA record. + -- + -- Add Records for those.. But not actually, usually, cnames! + -- Why not? Well, using cnames doesn't allow doing some things, + -- including MX and round robin DNS, and certianly CNAMES + -- shouldn't be used in SOA records. + -- + -- We typically know the host's IPAddrs anyway. + -- So we can just use the IPAddrs. + addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)] + addcnames attr = concatMap gen $ filter (inDomain zdomain) $ + mapMaybe getCNAME $ S.toList (_dns attr) + where + gen c = case getAddresses attr of + [] -> [ret (CNAME c)] + l -> map (ret . Address) l + where + ret record = Right (c, record) + + -- Adds any other DNS records for a host located in the zdomain. + hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)] + hostrecords attr = map Right l + where + l = zip (repeat $ AbsDomain $ _hostname attr) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr)) + +inDomain :: Domain -> BindDomain -> Bool +inDomain domain (AbsDomain d) = domain == d || ('.':domain) `isSuffixOf` d +inDomain _ _ = False -- can't tell, so assume not + +-- | Gets the hostname of the second domain, relative to the first domain, +-- suitable for using in a zone file. +domainHost :: Domain -> BindDomain -> String +domainHost _ (RelDomain d) = d +domainHost _ RootDomain = "@" +domainHost base (AbsDomain d) + | dotbase `isSuffixOf` d = take (length d - length dotbase) d + | base == d = "@" + | otherwise = d + where + dotbase = '.':base + diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs new file mode 100644 index 00000000..09d7d6a4 --- /dev/null +++ b/src/Propellor/Property/Docker.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Docker support for propellor +-- +-- The existance of a docker container is just another Property of a system, +-- which propellor can set up. See config.hs for an example. + +module Propellor.Property.Docker where + +import Propellor +import Propellor.SimpleSh +import Propellor.Types.Attr +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Docker.Shim as Shim +import Utility.SafeCommand +import Utility.Path + +import Control.Concurrent.Async +import System.Posix.Directory +import System.Posix.Process +import Data.List +import Data.List.Utils + +-- | Configures docker with an authentication file, so that images can be +-- pushed to index.docker.io. +configured :: Property +configured = property "docker configured" go `requires` installed + where + go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ + "/root/.dockercfg" `File.hasContent` (lines cfg) + +installed :: Property +installed = Apt.installed ["docker.io"] + +-- | A short descriptive name for a container. +-- Should not contain whitespace or other unusual characters, +-- only [a-zA-Z0-9_-] are allowed +type ContainerName = String + +-- | Starts accumulating the properties of a Docker container. +-- +-- > container "web-server" "debian" +-- > & publish "80:80" +-- > & Apt.installed {"apache2"] +-- > & ... +container :: ContainerName -> Image -> Host +container cn image = Host [] (\_ -> attr) + where + attr = (newAttr (cn2hn cn)) { _dockerImage = Just image } + +cn2hn :: ContainerName -> HostName +cn2hn cn = cn ++ ".docker" + +-- | Ensures that a docker container is set up and running. The container +-- has its own Properties which are handled by running propellor +-- inside the container. +-- +-- Reverting this property ensures that the container is stopped and +-- removed. +docked + :: [Host] + -> ContainerName + -> RevertableProperty +docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) + where + go desc a = property (desc ++ " " ++ cn) $ do + hn <- getHostName + let cid = ContainerId hn cn + ensureProperties [findContainer hosts cid cn $ a cid] + + setup cid (Container image runparams) = + provisionContainer cid + `requires` + runningContainer cid image runparams + `requires` + installed + + teardown cid (Container image _runparams) = + combineProperties ("undocked " ++ fromContainerId cid) + [ stoppedContainer cid + , property ("cleaned up " ++ fromContainerId cid) $ + liftIO $ report <$> mapM id + [ removeContainer cid + , removeImage image + ] + ] + +findContainer + :: [Host] + -> ContainerId + -> ContainerName + -> (Container -> Property) + -> Property +findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of + Nothing -> cantfind + Just h -> maybe cantfind mk (mkContainer cid h) + where + cantfind = containerDesc cid $ property "" $ do + liftIO $ warningMessage $ + "missing definition for docker container \"" ++ cn2hn cn + return FailedChange + +mkContainer :: ContainerId -> Host -> Maybe Container +mkContainer cid@(ContainerId hn _cn) h = Container + <$> _dockerImage attr + <*> pure (map (\a -> a hn) (_dockerRunParams attr)) + where + attr = hostAttr h' + h' = h + -- expose propellor directory inside the container + & volume (localdir++":"++localdir) + -- name the container in a predictable way so we + -- and the user can easily find it later + & name (fromContainerId cid) + +-- | Causes *any* docker images that are not in use by running containers to +-- be deleted. And deletes any containers that propellor has set up +-- before that are not currently running. Does not delete any containers +-- that were not set up using propellor. +-- +-- Generally, should come after the properties for the desired containers. +garbageCollected :: Property +garbageCollected = propertyList "docker garbage collected" + [ gccontainers + , gcimages + ] + where + gccontainers = property "docker containers garbage collected" $ + liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) + gcimages = property "docker images garbage collected" $ do + liftIO $ report <$> (mapM removeImage =<< listImages) + +data Container = Container Image [RunParam] + +-- | Parameters to pass to `docker run` when creating a container. +type RunParam = String + +-- | A docker image, that can be used to run a container. +type Image = String + +-- | Set custom dns server for container. +dns :: String -> Property +dns = runProp "dns" + +-- | Set container host name. +hostname :: String -> Property +hostname = runProp "hostname" + +-- | Set name for container. (Normally done automatically.) +name :: String -> Property +name = runProp "name" + +-- | Publish a container's port to the host +-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) +publish :: String -> Property +publish = runProp "publish" + +-- | Username or UID for container. +user :: String -> Property +user = runProp "user" + +-- | Mount a volume +-- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] +-- With just a directory, creates a volume in the container. +volume :: String -> Property +volume = runProp "volume" + +-- | Mount a volume from the specified container into the current +-- container. +volumes_from :: ContainerName -> Property +volumes_from cn = genProp "volumes-from" $ \hn -> + fromContainerId (ContainerId hn cn) + +-- | Work dir inside the container. +workdir :: String -> Property +workdir = runProp "workdir" + +-- | Memory limit for container. +--Format: , where unit = b, k, m or g +memory :: String -> Property +memory = runProp "memory" + +-- | Link with another container on the same host. +link :: ContainerName -> ContainerAlias -> Property +link linkwith calias = genProp "link" $ \hn -> + fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias + +-- | A short alias for a linked container. +-- Each container has its own alias namespace. +type ContainerAlias = String + +-- | A container is identified by its name, and the host +-- on which it's deployed. +data ContainerId = ContainerId HostName ContainerName + deriving (Eq, Read, Show) + +-- | Two containers with the same ContainerIdent were started from +-- the same base image (possibly a different version though), and +-- with the same RunParams. +data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] + deriving (Read, Show, Eq) + +ident2id :: ContainerIdent -> ContainerId +ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn + +toContainerId :: String -> Maybe ContainerId +toContainerId s + | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of + (cn, hn) + | null hn || null cn -> Nothing + | otherwise -> Just $ ContainerId hn cn + | otherwise = Nothing + where + desuffix = reverse . drop len . reverse + len = length myContainerSuffix + +fromContainerId :: ContainerId -> String +fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix + +containerHostName :: ContainerId -> HostName +containerHostName (ContainerId _ cn) = cn2hn cn + +myContainerSuffix :: String +myContainerSuffix = ".propellor" + +containerDesc :: ContainerId -> Property -> Property +containerDesc cid p = p `describe` desc + where + desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p + +runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do + l <- liftIO $ listContainers RunningContainers + if cid `elem` l + then do + -- Check if the ident has changed; if so the + -- parameters of the container differ and it must + -- be restarted. + runningident <- liftIO $ getrunningident + if runningident == Just ident + then noChange + else do + void $ liftIO $ stopContainer cid + restartcontainer + else ifM (liftIO $ elem cid <$> listContainers AllContainers) + ( restartcontainer + , go image + ) + where + ident = ContainerIdent image hn cn runps + + restartcontainer = do + oldimage <- liftIO $ fromMaybe image <$> commitContainer cid + void $ liftIO $ removeContainer cid + go oldimage + + getrunningident :: IO (Maybe ContainerIdent) + getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do + let !v = extractident rs + return v + + extractident :: [Resp] -> Maybe ContainerIdent + extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout + + go img = do + liftIO $ do + clearProvisionedFlag cid + createDirectoryIfMissing True (takeDirectory $ identFile cid) + shim <- liftIO $ Shim.setup (localdir "propellor") (localdir shimdir cid) + liftIO $ writeFile (identFile cid) (show ident) + ensureProperty $ boolProperty "run" $ runContainer img + (runps ++ ["-i", "-d", "-t"]) + [shim, "--docker", fromContainerId cid] + +-- | Called when propellor is running inside a docker container. +-- The string should be the container's ContainerId. +-- +-- This process is effectively init inside the container. +-- It even needs to wait on zombie processes! +-- +-- Fork a thread to run the SimpleSh server in the background. +-- In the foreground, run an interactive bash (or sh) shell, +-- so that the user can interact with it when attached to the container. +-- +-- When the system reboots, docker restarts the container, and this is run +-- again. So, to make the necessary services get started on boot, this needs +-- to provision the container then. However, if the container is already +-- being provisioned by the calling propellor, it would be redundant and +-- problimatic to also provisoon it here. +-- +-- The solution is a flag file. If the flag file exists, then the container +-- was already provisioned. So, it must be a reboot, and time to provision +-- again. If the flag file doesn't exist, don't provision here. +chain :: String -> IO () +chain s = case toContainerId s of + Nothing -> error $ "Invalid ContainerId: " ++ s + Just cid -> do + changeWorkingDirectory localdir + writeFile propellorIdent . show =<< readIdentFile cid + -- Run boot provisioning before starting simpleSh, + -- to avoid ever provisioning twice at the same time. + whenM (checkProvisionedFlag cid) $ do + let shim = Shim.file (localdir "propellor") (localdir shimdir cid) + unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $ + warningMessage "Boot provision failed!" + void $ async $ job reapzombies + void $ async $ job $ simpleSh $ namedPipe cid + job $ do + void $ tryIO $ ifM (inPath "bash") + ( boolSystem "bash" [Param "-l"] + , boolSystem "/bin/sh" [] + ) + putStrLn "Container is still running. Press ^P^Q to detach." + where + job = forever . void . tryIO + reapzombies = void $ getAnyProcessStatus True False + +-- | Once a container is running, propellor can be run inside +-- it to provision it. +-- +-- Note that there is a race here, between the simplesh +-- server starting up in the container, and this property +-- being run. So, retry connections to the client for up to +-- 1 minute. +provisionContainer :: ContainerId -> Property +provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do + let shim = Shim.file (localdir "propellor") (localdir shimdir cid) + r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) + when (r /= FailedChange) $ + setProvisionedFlag cid + return r + where + params = ["--continue", show $ Chain $ containerHostName cid] + + go lastline (v:rest) = case v of + StdoutLine s -> do + maybe noop putStrLn lastline + hFlush stdout + go (Just s) rest + StderrLine s -> do + maybe noop putStrLn lastline + hFlush stdout + hPutStrLn stderr s + hFlush stderr + go Nothing rest + Done -> ret lastline + go lastline [] = ret lastline + + ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline + +stopContainer :: ContainerId -> IO Bool +stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] + +stoppedContainer :: ContainerId -> Property +stoppedContainer cid = containerDesc cid $ property desc $ + ifM (liftIO $ elem cid <$> listContainers RunningContainers) + ( liftIO cleanup `after` ensureProperty + (boolProperty desc $ stopContainer cid) + , return NoChange + ) + where + desc = "stopped" + cleanup = do + nukeFile $ namedPipe cid + nukeFile $ identFile cid + removeDirectoryRecursive $ shimdir cid + clearProvisionedFlag cid + +removeContainer :: ContainerId -> IO Bool +removeContainer cid = catchBoolIO $ + snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing + +removeImage :: Image -> IO Bool +removeImage image = catchBoolIO $ + snd <$> processTranscript dockercmd ["rmi", image ] Nothing + +runContainer :: Image -> [RunParam] -> [String] -> IO Bool +runContainer image ps cmd = boolSystem dockercmd $ map Param $ + "run" : (ps ++ image : cmd) + +commitContainer :: ContainerId -> IO (Maybe Image) +commitContainer cid = catchMaybeIO $ + takeWhile (/= '\n') + <$> readProcess dockercmd ["commit", fromContainerId cid] + +data ContainerFilter = RunningContainers | AllContainers + deriving (Eq) + +-- | Only lists propellor managed containers. +listContainers :: ContainerFilter -> IO [ContainerId] +listContainers status = + catMaybes . map toContainerId . concat . map (split ",") + . catMaybes . map (lastMaybe . words) . lines + <$> readProcess dockercmd ps + where + ps + | status == AllContainers = baseps ++ ["--all"] + | otherwise = baseps + baseps = ["ps", "--no-trunc"] + +listImages :: IO [Image] +listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] + +runProp :: String -> RunParam -> Property +runProp field val = pureAttrProperty (param) $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] } + where + param = field++"="++val + +genProp :: String -> (HostName -> RunParam) -> Property +genProp field mkval = pureAttrProperty field $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] } + +-- | The ContainerIdent of a container is written to +-- /.propellor-ident inside it. This can be checked to see if +-- the container has the same ident later. +propellorIdent :: FilePath +propellorIdent = "/.propellor-ident" + +-- | Named pipe used for communication with the container. +namedPipe :: ContainerId -> FilePath +namedPipe cid = "docker" fromContainerId cid + +provisionedFlag :: ContainerId -> FilePath +provisionedFlag cid = "docker" fromContainerId cid ++ ".provisioned" + +clearProvisionedFlag :: ContainerId -> IO () +clearProvisionedFlag = nukeFile . provisionedFlag + +setProvisionedFlag :: ContainerId -> IO () +setProvisionedFlag cid = do + createDirectoryIfMissing True (takeDirectory (provisionedFlag cid)) + writeFile (provisionedFlag cid) "1" + +checkProvisionedFlag :: ContainerId -> IO Bool +checkProvisionedFlag = doesFileExist . provisionedFlag + +shimdir :: ContainerId -> FilePath +shimdir cid = "docker" fromContainerId cid ++ ".shim" + +identFile :: ContainerId -> FilePath +identFile cid = "docker" fromContainerId cid ++ ".ident" + +readIdentFile :: ContainerId -> IO ContainerIdent +readIdentFile cid = fromMaybe (error "bad ident in identFile") + . readish <$> readFile (identFile cid) + +dockercmd :: String +dockercmd = "docker.io" + +report :: [Bool] -> Result +report rmed + | or rmed = MadeChange + | otherwise = NoChange + diff --git a/src/Propellor/Property/Docker/Shim.hs b/src/Propellor/Property/Docker/Shim.hs new file mode 100644 index 00000000..c2f35d0c --- /dev/null +++ b/src/Propellor/Property/Docker/Shim.hs @@ -0,0 +1,61 @@ +-- | Support for running propellor, as built outside a docker container, +-- inside the container. +-- +-- Note: This is currently Debian specific, due to glibcLibs. + +module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where + +import Propellor +import Utility.LinuxMkLibs +import Utility.SafeCommand +import Utility.Path +import Utility.FileMode + +import Data.List +import System.Posix.Files + +-- | Sets up a shimmed version of the program, in a directory, and +-- returns its path. +setup :: FilePath -> FilePath -> IO FilePath +setup propellorbin dest = do + createDirectoryIfMissing True dest + + libs <- parseLdd <$> readProcess "ldd" [propellorbin] + glibclibs <- glibcLibs + let libs' = nub $ libs ++ glibclibs + libdirs <- map (dest ++) . nub . catMaybes + <$> mapM (installLib installFile dest) libs' + + let linker = (dest ++) $ + fromMaybe (error "cannot find ld-linux linker") $ + headMaybe $ filter ("ld-linux" `isInfixOf`) libs' + let gconvdir = (dest ++) $ parentDir $ + fromMaybe (error "cannot find gconv directory") $ + headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs + let linkerparams = ["--library-path", intercalate ":" libdirs ] + let shim = file propellorbin dest + writeFile shim $ unlines + [ "#!/bin/sh" + , "GCONV_PATH=" ++ shellEscape gconvdir + , "export GCONV_PATH" + , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ + " " ++ shellEscape propellorbin ++ " \"$@\"" + ] + modifyFileMode shim (addModes executeModes) + return shim + +cleanEnv :: IO () +cleanEnv = void $ unsetEnv "GCONV_PATH" + +file :: FilePath -> FilePath -> FilePath +file propellorbin dest = dest takeFileName propellorbin + +installFile :: FilePath -> FilePath -> IO () +installFile top f = do + createDirectoryIfMissing True destdir + nukeFile dest + createLink f dest `catchIO` (const copy) + where + copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] + destdir = inTop top $ parentDir f + dest = inTop top f diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs new file mode 100644 index 00000000..0b060177 --- /dev/null +++ b/src/Propellor/Property/File.hs @@ -0,0 +1,94 @@ +module Propellor.Property.File where + +import Propellor +import Utility.FileMode + +import System.Posix.Files +import System.PosixCompat.Types + +type Line = String + +-- | Replaces all the content of a file. +hasContent :: FilePath -> [Line] -> Property +f `hasContent` newcontent = fileProperty ("replace " ++ f) + (\_oldcontent -> newcontent) f + +-- | Ensures a file has contents that comes from PrivData. +-- +-- The file's permissions are preserved if the file already existed. +-- Otherwise, they're set to 600. +hasPrivContent :: FilePath -> Property +hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent -> + ensureProperty $ fileProperty' writeFileProtected desc + (\_oldcontent -> lines privcontent) f + where + desc = "privcontent " ++ f + +-- | Leaves the file world-readable. +hasPrivContentExposed :: FilePath -> Property +hasPrivContentExposed f = hasPrivContent f `onChange` + mode f (combineModes (ownerWriteMode:readModes)) + +-- | Ensures that a line is present in a file, adding it to the end if not. +containsLine :: FilePath -> Line -> Property +f `containsLine` l = f `containsLines` [l] + +containsLines :: FilePath -> [Line] -> Property +f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f + where + go ls + | all (`elem` ls) l = ls + | otherwise = ls++l + +-- | 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. +lacksLine :: FilePath -> Line -> Property +f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f + +-- | Removes a file. Does not remove symlinks or non-plain-files. +notPresent :: FilePath -> Property +notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ + makeChange $ nukeFile f + +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty = fileProperty' writeFile +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) + where + go True = do + ls <- liftIO $ lines <$> readFile f + let ls' = a ls + if ls' == ls + then noChange + else makeChange $ viaTmp updatefile f (unlines ls') + go False = makeChange $ writer f (unlines $ a []) + + -- viaTmp makes the temp file mode 600. + -- Replicate the original file's owner and mode. + updatefile f' content = do + writer f' content + s <- getFileStatus f + setFileMode f' (fileMode s) + setOwnerAndGroup f' (fileOwner s) (fileGroup s) + +-- | Ensures a directory exists. +dirExists :: FilePath -> Property +dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ + makeChange $ createDirectoryIfMissing True d + +-- | Ensures that a file/dir has the specified owner and group. +ownerGroup :: FilePath -> UserName -> GroupName -> Property +ownerGroup f owner group = property (f ++ " owner " ++ og) $ do + r <- ensureProperty $ cmdProperty "chown" [og, f] + if r == FailedChange + then return r + else noChange + where + og = owner ++ ":" ++ group + +-- | Ensures that a file/dir has the specfied mode. +mode :: FilePath -> FileMode -> Property +mode f v = property (f ++ " mode " ++ show v) $ do + liftIO $ modifyFileMode f (\_old -> v) + noChange diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs new file mode 100644 index 00000000..e5df7e48 --- /dev/null +++ b/src/Propellor/Property/Git.hs @@ -0,0 +1,93 @@ +module Propellor.Property.Git where + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service +import Utility.SafeCommand + +import Data.List + +-- | Exports all git repos in a directory (that user nobody can read) +-- using git-daemon, run from inetd. +-- +-- Note that reverting this property does not remove or stop inetd. +daemonRunning :: FilePath -> RevertableProperty +daemonRunning exportdir = RevertableProperty setup unsetup + where + setup = containsLine conf (mkl "tcp4") + `requires` + containsLine conf (mkl "tcp6") + `requires` + dirExists exportdir + `requires` + Apt.serviceInstalledRunning "openbsd-inetd" + `onChange` + Service.running "openbsd-inetd" + `describe` ("git-daemon exporting " ++ exportdir) + unsetup = lacksLine conf (mkl "tcp4") + `requires` + lacksLine conf (mkl "tcp6") + `onChange` + Service.reloaded "openbsd-inetd" + + conf = "/etc/inetd.conf" + + mkl tcpv = intercalate "\t" + [ "git" + , "stream" + , tcpv + , "nowait" + , "nobody" + , "/usr/bin/git" + , "git" + , "daemon" + , "--inetd" + , "--export-all" + , "--base-path=" ++ exportdir + , exportdir + ] + +installed :: Property +installed = Apt.installed ["git"] + +type RepoUrl = String + +type Branch = String + +-- | Specified git repository is cloned to the specified directory. +-- +-- If the firectory exists with some other content, it will be recursively +-- deleted. +-- +-- A branch can be specified, to check out. +cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property +cloned owner url dir mbranch = check originurl (property desc checkout) + `requires` installed + where + desc = "git cloned " ++ url ++ " to " ++ dir + gitconfig = dir ".git/config" + originurl = ifM (doesFileExist gitconfig) + ( do + v <- catchDefaultIO Nothing $ headMaybe . lines <$> + readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"] + return (v /= Just url) + , return True + ) + checkout = do + liftIO $ do + whenM (doesDirectoryExist dir) $ + removeDirectoryRecursive dir + createDirectoryIfMissing True (takeDirectory dir) + ensureProperty $ userScriptProperty owner $ catMaybes + -- The mbranch + -- In case this repo is exposted via the web, + -- although the hook to do this ongoing is not + -- installed here. + , Just "git update-server-info" + ] diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs new file mode 100644 index 00000000..64ea9fea --- /dev/null +++ b/src/Propellor/Property/Gpg.hs @@ -0,0 +1,41 @@ +module Propellor.Property.Gpg where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.FileSystemEncoding + +import System.PosixCompat + +installed :: Property +installed = Apt.installed ["gnupg"] + +-- | Sets up a user with a gpg key from the privdata. +-- +-- Note that if a secret key is exported using gpg -a --export-secret-key, +-- the public key is also included. Or just a public key could be +-- exported, and this would set it up just as well. +-- +-- Recommend only using this for low-value dedicated role keys. +-- No attempt has been made to scrub the key out of memory once it's used. +-- +-- The GpgKeyId does not have to be a numeric id; it can just as easily +-- be a description of the key. +keyImported :: GpgKeyId -> UserName -> Property +keyImported keyid user = flagFile' (property desc go) genflag + `requires` installed + where + desc = user ++ " has gpg key " ++ show keyid + genflag = do + d <- dotDir user + return $ d ".propellor-imported-keyid-" ++ keyid + go = withPrivData (GpgKey keyid) $ \key -> makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "su" ["-c", "gpg --import", user]) $ \h -> do + fileEncoding h + hPutStr h key + hClose h + +dotDir :: UserName -> IO FilePath +dotDir user = do + home <- homeDirectory <$> getUserEntryForName user + return $ home ".gnupg" diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs new file mode 100644 index 00000000..031abb9d --- /dev/null +++ b/src/Propellor/Property/Hostname.hs @@ -0,0 +1,33 @@ +module Propellor.Property.Hostname where + +import Propellor +import qualified Propellor.Property.File as File + +-- | Ensures that the hostname is set to the HostAttr value. +-- Configures /etc/hostname and the current hostname. +-- +-- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is +-- standard at least on Debian to set the FDQN (127.0.0.1 is localhost). +sane :: Property +sane = property ("sane hostname") (ensureProperty . setTo =<< getHostName) + +setTo :: HostName -> Property +setTo hn = combineProperties desc go + `onChange` cmdProperty "hostname" [basehost] + where + desc = "hostname " ++ hn + (basehost, domain) = separate (== '.') hn + + go = catMaybes + [ Just $ "/etc/hostname" `File.hasContent` [basehost] + , if null domain + then Nothing + else Just $ File.fileProperty desc + addhostline "/etc/hosts" + ] + + hostip = "127.0.1.1" + hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost + + addhostline ls = hostline : filter (not . hashostip) ls + hashostip l = headMaybe (words l) == Just hostip diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs new file mode 100644 index 00000000..6009778a --- /dev/null +++ b/src/Propellor/Property/Network.hs @@ -0,0 +1,30 @@ +module Propellor.Property.Network where + +import Propellor +import Propellor.Property.File + +interfaces :: FilePath +interfaces = "/etc/network/interfaces" + +-- | 6to4 ipv6 connection, should work anywhere +ipv6to4 :: Property +ipv6to4 = fileProperty "ipv6to4" go interfaces + `onChange` ifUp "sit0" + where + go ls + | all (`elem` ls) stanza = ls + | otherwise = ls ++ stanza + stanza = + [ "# Automatically added by propeller" + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "auto sit0" + , "# End automatically added by propeller" + ] + +type Interface = String + +ifUp :: Interface -> Property +ifUp iface = cmdProperty "ifup" [iface] diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs new file mode 100644 index 00000000..32374b57 --- /dev/null +++ b/src/Propellor/Property/Obnam.hs @@ -0,0 +1,155 @@ +module Propellor.Property.Obnam where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Cron as Cron +import Utility.SafeCommand + +import Data.List + +type ObnamParam = String + +-- | An obnam repository can be used by multiple clients. Obnam uses +-- locking to allow only one client to write at a time. Since stale lock +-- files can prevent backups from happening, it's more robust, if you know +-- a repository has only one client, to force the lock before starting a +-- backup. Using OnlyClient allows propellor to do so when running obnam. +data NumClients = OnlyClient | MultipleClients + deriving (Eq) + +-- | Installs a cron job that causes a given directory to be backed +-- up, by running obnam 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. +-- And since Obnam encrypts, just make this property depend on a gpg +-- key, and tell obnam to use the key, and your data will be backed +-- up securely. For example: +-- +-- > & Obnam.backup "/srv/git" "33 3 * * *" +-- > [ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam" +-- > , "--encrypt-with=1B169BE1" +-- > ] Obnam.OnlyClient +-- > `requires` Gpg.keyImported "1B169BE1" "root" +-- > `requires` Ssh.keyImported SshRsa "root" +-- +-- How awesome is that? +backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup dir crontimes params numclients = cronjob `describe` desc + `requires` restored dir params + where + desc = dir ++ " backed up by obnam" + cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $ + intercalate ";" $ catMaybes + [ if numclients == OnlyClient + then Just $ unwords $ + [ "obnam" + , "force-lock" + ] ++ map shellEscape params + else Nothing + , Just $ unwords $ + [ "obnam" + , "backup" + , shellEscape dir + ] ++ map shellEscape params + ] + +-- | Restores a directory from an obnam 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 -> [ObnamParam] -> Property +restored dir params = property (dir ++ " restored by obnam") go + `requires` installed + where + go = ifM (liftIO needsRestore) + ( do + warningMessage $ dir ++ " is empty/missing; restoring from backup ..." + liftIO restore + , noChange + ) + + needsRestore = null <$> catchDefaultIO [] (dirContents dir) + + restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do + ok <- boolSystem "obnam" $ + [ Param "restore" + , Param "--to" + , Param tmpdir + ] ++ map Param params + let restoreddir = tmpdir ++ "/" ++ dir + ifM (pure ok <&&> doesDirectoryExist restoreddir) + ( do + void $ tryIO $ removeDirectory dir + renameDirectory restoreddir dir + return MadeChange + , return FailedChange + ) + +installed :: Property +installed = Apt.installed ["obnam"] + +-- | Ensures that a recent version of obnam gets installed. +-- +-- Only does anything for Debian Stable. +latestVersion :: Property +latestVersion = withOS "obnam latest version" $ \o -> case o of + (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ + Apt.setSourcesListD (sources suite) "obnam" + `requires` toProp (Apt.trustsKey key) + _ -> noChange + where + sources suite = + [ "deb http://code.liw.fi/debian " ++ Apt.showSuite suite ++ " main" + ] + -- gpg key used by the code.liw.fi repository. + key = Apt.AptKey "obnam" $ unlines + [ "-----BEGIN PGP PUBLIC KEY BLOCK-----" + , "Version: GnuPG v1.4.9 (GNU/Linux)" + , "" + , "mQGiBEfzuTgRBACcVNG/H6QJqLx5qiQs2zmPe6D6BWOWHfgNgG4IWzNstm21YDxb" + , "KqwFG0gxcnZJGHkXAhkSfqTokYd0lc5eBemcA1pkceNjzMEX8wwiZ810HzJD4eEH" + , "sjoWR8+qKrZeixzZqReAfqztcXoBGKQ0u1R1vpg1txUa75OM4BUqaUbsmwCgmS4x" + , "DjMxSaUSPuu6vQ7ZGZBXSP0D/RQw8DBHMfsv3DiaqFqk8tkuUkpMFPIekHidSHlO" + , "EACbncqbbyHksyCpFNVNcQIDHrOLjOZK9BAXkSd8I3ww7U+nLdDcCblrW8CZnJtm" + , "ZYrxfaXaHZ/It9/RCAsQ+c8xtmyUPjsf//4Vf8olxNQHzgBSe5/LJRi4Vd53he+K" + , "YP4LA/9IZbjvVmm8+8Y0pQrTHlI6nTImtzdBXHc4+T3lLBj9XODHLozC2kSBOQky" + , "q/EisTITHTXL8vYg4NsKm5RTbPAuBwdtxcny8CXfOqKtGOdrebmKotGllTozzdPv" + , "9p53cuce6oJ2oMUodc074JOGTWwDSgLiJX4nViGcU1wy/vtQnrQkY29kZS5saXcu" + , "ZmkgYXJjaGl2ZSBrZXkgPGxpd0BsaXcuZmk+iGAEExECACAFAkfzuTgCGwMGCwkI" + , "BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRBG53tJR95LscKrAJ0ZtKqa2x6Kplwa2mzx" + , "ItImbIGMJACdETqofDYzUN91yLAFlOnxAyrE+UyIRgQQEQIABgUCSFd5GgAKCRAf" + , "u5W/LZrMjqr8AJ4xPVHpW8ZNlgMwDSVb075RnA2DiACgg2SR69jAHFQOWV6xfLRr" + , "vh0bLKGJAhwEEAEIAAYFAktEyIwACgkQ61zh116FEfm7Lg//Wiy3TjWAk8YHUddv" + , "zOioYzCxQ985GsVhJGAVPqSGOc9vfTWBJZ8J3l0NnYTRpEGucmbF9G+mAt9iGXu6" + , "7yZkxyFdvbo7EDsqMU1wLOM6PiU+Un63MKlbTNmFn7OKE8aXPRAFgcyUO/qjdqoD" + , "sa9FgU5Z0f60m9qah6BPXH6IzMLHYoiP7t8rCBIwLgyl3w2w+Fjt1DFpbW9Kb7jz" + , "i8jFvC8jPmxV8xh2OSgVZyNk4qg6hIV8GVQY7AJt8OurZSckgQd7ifHK9JTGohtF" + , "tXCiqeDEvnMF4A9HI/TcXJBzonZ8ds1JCq42nSSKmL+8TyjtUSD/xHygazuc0CK0" + , "hFnQWBub60IfyV6F0oTagJ8cmARv2sezHAeHDkzPHE8RdjgktazH1eJrA4LheEd6" + , "KeSnVtYWpw8dgMv5PleFyQiAj/t3C/N50fd15tUyfnH15G7nFjMQV2Yx35uwSxOj" + , "376OWnDN/YGTNk283XXULbyVJYR8Q2unso20XQ94yQ2A5EpHHPrHoLxrL/ydM08d" + , "nvKstLZIZtal1seiMkymtlSiGz25A5oqsclwS6VZCKdWA8HO/wlElOMcaHyl6Y1y" + , "gYP7y9O5yFYKFOrCH0nFjJbwmkRiBLsxuuWsYgJigVGq/atSrtawkHdshpCw0HCY" + , "N/RFcWkJ864BdsO0C0sDzueNkQO5Ag0ER/O5RBAIAJiwPH9tyJTgXcC2Y4XWboOq" + , "rx5CkOnr5b45oS9cK2eIJ8TKxE3XgKLxUr3mIH0QR2kZgDOwNl0WY+7/CXjn+Spn" + , "BokPg54rafEUePodGpGdUXdgrHhAMHYjh8fXFJ1SlQcg46/zc1wDI7jBCkGrK3V8" + , "5cXDqwTFTN5LcjoSRWeM4Voa6pEfDdL3rMlnOw9R9gDHRBBb6CDSjWXqM86pR889" + , "5QrR0SDwiJNrMoyxSjMXFKGBQAsYHJ82myZrlbuZbroZjVp5Uh7eB1ZiPljNVtcr" + , "sksACIWBCo1rvLzrPXsLYOeV3cDDtYAkSwGfuzC1Etbe+qgfIroFTOqdefMw4s8A" + , "AwUH/0KLXm4MS54QQspg3evu4Q4U/E8Hem5/FqB0GhBCitQ4rUsucKyY8/ItpUn5" + , "ismLE60bQqka+Mzd/Zw18TCTzImv0ozAaZ2sNtBado7f6jcC8EDfY5zzK1ukcsAr" + , "Qc5hdLHYuTQW5KpA6fKaW969OUzIwPbdVaCOLOBpxKC6N6iBspQYd6uiQtLw6EUO" + , "50oQqUiJABf0eOocvdw5e2KQQpuC3205+VMYtyl4w3pdJihK8NK0AikGXzDVsbQt" + , "l8kmB5ZrN4WIKhMke1FxbqQC5Q3XATvYRzpzzisZb/HYGNti8W6du5EUwJ0D2NRh" + , "cu+twocOzW0VKfmrDApfifJ9OsSISQQYEQIACQUCR/O5RAIbDAAKCRBG53tJR95L" + , "seQOAJ95KUyzjRjdYgZkDC69Mgu25L86UACdGduINUaRly43ag4kwUXxpqswBBM=" + , "=i2c3" + , "-----END PGP PUBLIC KEY BLOCK-----" + ] diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs new file mode 100644 index 00000000..051d6425 --- /dev/null +++ b/src/Propellor/Property/OpenId.hs @@ -0,0 +1,29 @@ +module Propellor.Property.OpenId where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +import Data.List + +providerFor :: [UserName] -> String -> Property +providerFor users baseurl = propertyList desc $ + [ Apt.serviceInstalledRunning "apache2" + , Apt.installed ["simpleid"] + `onChange` Service.restarted "apache2" + , File.fileProperty (desc ++ " configured") + (map setbaseurl) "/etc/simpleid/config.inc" + ] ++ map identfile users + where + url = "http://"++baseurl++"/simpleid" + desc = "openid provider " ++ url + setbaseurl l + | "SIMPLEID_BASE_URL" `isInfixOf` l = + "define('SIMPLEID_BASE_URL', '"++url++"');" + | otherwise = l + + -- the identitites directory controls access, so open up + -- file mode + identfile u = File.hasPrivContentExposed $ + concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ] diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs new file mode 100644 index 00000000..9fa4a2c3 --- /dev/null +++ b/src/Propellor/Property/Postfix.hs @@ -0,0 +1,25 @@ +module Propellor.Property.Postfix where + +import Propellor +import qualified Propellor.Property.Apt as Apt + +installed :: Property +installed = Apt.serviceInstalledRunning "postfix" + +-- | Configures postfix as a satellite system, which +-- relats all mail through a relay host, which defaults to smtp.domain. +-- +-- The smarthost may refuse to relay mail on to other domains, without +-- futher coniguration/keys. But this should be enough to get cron job +-- mail flowing to a place where it will be seen. +satellite :: Property +satellite = setup `requires` installed + where + setup = trivial $ property "postfix satellite system" $ do + hn <- getHostName + ensureProperty $ Apt.reConfigure "postfix" + [ ("postfix/main_mailer_type", "select", "Satellite system") + , ("postfix/root_address", "string", "root") + , ("postfix/destinations", "string", " ") + , ("postfix/mailname", "string", hn) + ] diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs new file mode 100644 index 00000000..25e53159 --- /dev/null +++ b/src/Propellor/Property/Reboot.hs @@ -0,0 +1,7 @@ +module Propellor.Property.Reboot where + +import Propellor + +now :: Property +now = cmdProperty "reboot" [] + `describe` "reboot now" diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs new file mode 100644 index 00000000..f2911e50 --- /dev/null +++ b/src/Propellor/Property/Scheduled.hs @@ -0,0 +1,67 @@ +module Propellor.Property.Scheduled + ( period + , periodParse + , Recurrance(..) + , WeekDay + , MonthDay + , YearDay + ) where + +import Propellor +import Utility.Scheduled + +import Data.Time.Clock +import Data.Time.LocalTime +import qualified Data.Map as M + +-- | Makes a Property only be checked every so often. +-- +-- This uses the description of the Property to keep track of when it was +-- last run. +period :: Property -> Recurrance -> Property +period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do + lasttime <- liftIO $ getLastChecked (propertyDesc prop) + nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime + t <- liftIO localNow + if Just t >= nexttime + then do + r <- satisfy + liftIO $ setLastChecked t (propertyDesc prop) + return r + else noChange + where + schedule = Schedule recurrance AnyTime + desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + +-- | Like period, but parse a human-friendly string. +periodParse :: Property -> String -> Property +periodParse prop s = case toRecurrance s of + Just recurrance -> period prop recurrance + Nothing -> property "periodParse" $ do + liftIO $ warningMessage $ "failed periodParse: " ++ s + noChange + +lastCheckedFile :: FilePath +lastCheckedFile = localdir ".lastchecked" + +getLastChecked :: Desc -> IO (Maybe LocalTime) +getLastChecked desc = M.lookup desc <$> readLastChecked + +localNow :: IO LocalTime +localNow = do + now <- getCurrentTime + tz <- getTimeZone now + return $ utcToLocalTime tz now + +setLastChecked :: LocalTime -> Desc -> IO () +setLastChecked time desc = do + m <- readLastChecked + writeLastChecked (M.insert desc time m) + +readLastChecked :: IO (M.Map Desc LocalTime) +readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go + where + go = readish <$> readFileStrict lastCheckedFile + +writeLastChecked :: M.Map Desc LocalTime -> IO () +writeLastChecked = writeFile lastCheckedFile . show diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs new file mode 100644 index 00000000..14e769d0 --- /dev/null +++ b/src/Propellor/Property/Service.hs @@ -0,0 +1,31 @@ +module Propellor.Property.Service where + +import Propellor +import Utility.SafeCommand + +type ServiceName = String + +-- | Ensures that a service is running. Does not ensure that +-- any package providing that service is installed. See +-- Apt.serviceInstalledRunning +-- +-- Note that due to the general poor state of init scripts, the best +-- we can do is try to start the service, and if it fails, assume +-- this means it's already running. +running :: ServiceName -> Property +running svc = property ("running " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] + return NoChange + +restarted :: ServiceName -> Property +restarted svc = property ("restarted " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"] + return NoChange + +reloaded :: ServiceName -> Property +reloaded svc = property ("reloaded " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"] + return NoChange diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs new file mode 100644 index 00000000..677aa760 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -0,0 +1,57 @@ +module Propellor.Property.SiteSpecific.GitAnnexBuilder where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Cron as Cron +import Propellor.Property.Cron (CronTimes) + +builduser :: UserName +builduser = "builder" + +homedir :: FilePath +homedir = "/home/builder" + +gitbuilderdir :: FilePath +gitbuilderdir = homedir "gitbuilder" + +builddir :: FilePath +builddir = gitbuilderdir "build" + +builder :: Architecture -> CronTimes -> Bool -> Property +builder arch crontimes rsyncupload = combineProperties "gitannexbuilder" + [ Apt.stdSourcesList Unstable + , Apt.buildDep ["git-annex"] + , Apt.installed ["git", "rsync", "moreutils", "ca-certificates", + "liblockfile-simple-perl", "cabal-install", "vim", "less"] + , Apt.serviceInstalledRunning "cron" + , User.accountFor builduser + , check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser + [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir + , "cd " ++ gitbuilderdir + , "git checkout " ++ arch + ] + `describe` "gitbuilder setup" + , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + [ "git clone git://git-annex.branchable.com/ " ++ builddir + ] + , "git-annex source build deps installed" ==> Apt.buildDepIn builddir + , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild" + -- The builduser account does not have a password set, + -- instead use the password privdata to hold the rsync server + -- password used to upload the built image. + , property "rsync password" $ do + let f = homedir "rsyncpassword" + if rsyncupload + then withPrivData (Password builduser) $ \p -> do + oldp <- liftIO $ catchDefaultIO "" $ + readFileStrict f + if p /= oldp + then makeChange $ writeFile f p + else noChange + else do + ifM (liftIO $ doesFileExist f) + ( noChange + , makeChange $ writeFile f "no password configured" + ) + ] diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs new file mode 100644 index 00000000..6ed02146 --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -0,0 +1,34 @@ +module Propellor.Property.SiteSpecific.GitHome where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User +import Utility.SafeCommand + +-- | Clones Joey Hess's git home directory, and runs its fixups script. +installedFor :: UserName -> Property +installedFor user = check (not <$> hasGitDir user) $ + property ("githome " ++ user) (go =<< liftIO (homedir user)) + `requires` Apt.installed ["git"] + where + go home = do + let tmpdir = home "githome" + ensureProperty $ combineProperties "githome setup" + [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir] + , property "moveout" $ makeChange $ void $ + moveout tmpdir home + , property "rmdir" $ makeChange $ void $ + catchMaybeIO $ removeDirectory tmpdir + , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] + ] + moveout tmpdir home = do + fs <- dirContents tmpdir + forM fs $ \f -> boolSystem "mv" [File f, File home] + +url :: String +url = "git://git.kitenet.net/joey/home" + +hasGitDir :: UserName -> IO Bool +hasGitDir user = go =<< homedir user + where + go home = doesDirectoryExist (home ".git") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs new file mode 100644 index 00000000..28b3dffd --- /dev/null +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -0,0 +1,314 @@ +-- | Specific configuation for Joey Hess's sites. Probably not useful to +-- others except as an example. + +module Propellor.Property.SiteSpecific.JoeySites where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Gpg as Gpg +import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Git as Git +import qualified Propellor.Property.Cron as Cron +import qualified Propellor.Property.Service as Service +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Obnam as Obnam +import qualified Propellor.Property.Apache as Apache +import Utility.SafeCommand +import Utility.FileMode + +import Data.List +import System.Posix.Files + +oldUseNetServer :: [Host] -> Property +oldUseNetServer hosts = propertyList ("olduse.net server") + [ oldUseNetInstalled "oldusenet-server" + , Obnam.latestVersion + , Obnam.backup datadir "33 4 * * *" + [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" + , "--client-name=spool" + ] Obnam.OnlyClient + `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ + property "olduse.net spool in place" $ makeChange $ do + removeDirectoryRecursive newsspool + createSymbolicLink (datadir "news") newsspool + , Apt.installed ["leafnode"] + , "/etc/news/leafnode/config" `File.hasContent` + [ "# olduse.net configuration (deployed by propellor)" + , "expire = 1000000" -- no expiry via texpire + , "server = " -- no upstream server + , "debugmode = 1" + , "allowSTRANGERS = 42" -- lets anyone connect + , "nopost = 1" -- no new posting (just gather them) + ] + , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" + , Apt.serviceInstalledRunning "openbsd-inetd" + , File.notPresent "/etc/cron.daily/leafnode" + , File.notPresent "/etc/cron.d/leafnode" + , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" + [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" + , "find -type d -empty | xargs --no-run-if-empty rmdir" + ] + , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ + "/usr/bin/uucp " ++ datadir + , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False + [ " DocumentRoot " ++ datadir ++ "/" + , " " + , " Options Indexes FollowSymlinks" + , " AllowOverride None" + -- I had this in the file before. + -- This may be needed by a newer version of apache? + --, " Require all granted" + , " " + ] + ] + where + newsspool = "/var/spool/news" + datadir = "/var/spool/oldusenet" + +oldUseNetShellBox :: Property +oldUseNetShellBox = oldUseNetInstalled "oldusenet" + +oldUseNetInstalled :: Apt.Package -> Property +oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ + propertyList ("olduse.net " ++ pkg) + [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") + `describe` "olduse.net build deps" + , scriptProperty + [ "rm -rf /root/tmp/oldusenet" -- idenpotency + , "git clone git://olduse.net/ /root/tmp/oldusenet/source" + , "cd /root/tmp/oldusenet/source/" + , "dpkg-buildpackage -us -uc" + , "dpkg -i ../" ++ pkg ++ "_*.deb || true" + , "apt-get -fy install" -- dependencies + , "rm -rf /root/tmp/oldusenet" + ] `describe` "olduse.net built" + ] + + +kgbServer :: Property +kgbServer = withOS desc $ \o -> case o of + (Just (System (Debian Unstable) _)) -> + ensureProperty $ propertyList desc + [ Apt.serviceInstalledRunning "kgb-bot" + , File.hasPrivContent "/etc/kgb-bot/kgb.conf" + `onChange` Service.restarted "kgb-bot" + , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" + `describe` "kgb bot enabled" + `onChange` Service.running "kgb-bot" + ] + _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" + where + desc = "kgb.kitenet.net setup" + +mumbleServer :: [Host] -> Property +mumbleServer hosts = combineProperties "mumble.debian.net" + [ Apt.serviceInstalledRunning "mumble-server" + , Obnam.latestVersion + , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" + [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam" + , "--client-name=mumble" + ] Obnam.OnlyClient + `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.knownHost hosts "turtle.kitenet.net" "root" + , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] + ] + +obnamLowMem :: Property +obnamLowMem = combineProperties "obnam tuned for low memory use" + [ Obnam.latestVersion + , "/etc/obnam.conf" `File.containsLines` + [ "[config]" + , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)." + , "upload-queue-size = 128" + , "lru-size = 128" + ] + ] + +-- git.kitenet.net and git.joeyh.name +gitServer :: [Host] -> Property +gitServer hosts = propertyList "git.kitenet.net setup" + [ Obnam.latestVersion + , Obnam.backup "/srv/git" "33 3 * * *" + [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" + , "--encrypt-with=1B169BE1" + , "--client-name=wren" + ] Obnam.OnlyClient + `requires` Gpg.keyImported "1B169BE1" "root" + `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + `requires` Ssh.authorizedKeys "family" + `requires` User.accountFor "family" + , Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"] + , Apt.installedBackport ["git-annex"] + , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" + , toProp $ 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" "joey" + -- I keep the website used for gitweb checked into git.. + , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + , website "git.kitenet.net" + , website "git.joeyh.name" + , toProp $ Apache.modEnabled "cgi" + ] + where + website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True + [ " DocumentRoot /srv/web/git.kitenet.net/" + , " " + , " Options Indexes ExecCGI FollowSymlinks" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.cgi" + , " " + , "" + , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" + , " " + , " SetHandler cgi-script" + , " Options ExecCGI" + , " " + ] + +type AnnexUUID = String + +-- | A website, with files coming from a git-annex repository. +annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property +annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex") + [ Git.cloned "joey" origin dir Nothing + `onChange` setup + , postupdatehook `File.hasContent` + [ "#!/bin/sh" + , "exec git update-server-info" + ] `onChange` + (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) + , setupapache + ] + where + dir = "/srv/web/" ++ hn + postupdatehook = dir ".git/hooks/post-update" + setup = userScriptProperty "joey" setupscript + `requires` Ssh.keyImported SshRsa "joey" + `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey" + setupscript = + [ "cd " ++ shellEscape dir + , "git config annex.uuid " ++ shellEscape uuid + ] ++ map addremote remotes ++ + [ "git annex get" + ] + addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url + setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ + [ " ServerAlias www."++hn + , "" + , " DocumentRoot /srv/web/"++hn + , " " + , " Options FollowSymLinks" + , " AllowOverride None" + , " " + , " " + , " Options Indexes FollowSymLinks ExecCGI" + , " AllowOverride None" + , " AddHandler cgi-script .cgi" + , " DirectoryIndex index.html index.cgi" + , " Order allow,deny" + , " allow from all" + , " " + ] + +apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile +apachecfg hn withssl middle + | withssl = vhost False ++ vhost True + | otherwise = vhost False + where + vhost ssl = + [ "" + , " ServerAdmin grue@joeyh.name" + , " ServerName "++hn++":"++show port + ] + ++ mainhttpscert ssl + ++ middle ++ + [ "" + , " ErrorLog /var/log/apache2/error.log" + , " LogLevel warn" + , " CustomLog /var/log/apache2/access.log combined" + , " ServerSignature On" + , " " + , " " + , " Options Indexes MultiViews" + , " AllowOverride None" + , " Order allow,deny" + , " Allow from all" + , " " + , "" + ] + where + port = if ssl then 443 else 80 :: Int + +mainhttpscert :: Bool -> Apache.ConfigFile +mainhttpscert False = [] +mainhttpscert True = + [ " SSLEngine on" + , " SSLCertificateFile /etc/ssl/certs/web.pem" + , " SSLCertificateKeyFile /etc/ssl/private/web.pem" + , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" + ] + +gitAnnexDistributor :: Property +gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" + [ Apt.installed ["rsync"] + , File.hasPrivContent "/etc/rsyncd.conf" + , File.hasPrivContent "/etc/rsyncd.secrets" + , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" + `onChange` Service.running "rsync" + , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" + , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" + -- git-annex distribution signing key + , Gpg.keyImported "89C809CB" "joey" + ] + where + endpoint d = combineProperties ("endpoint " ++ d) + [ File.dirExists d + , File.ownerGroup d "joey" "joey" + ] + +-- Twitter, you kill us. +twitRss :: Property +twitRss = combineProperties "twitter rss" + [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing + , check (not <$> doesFileExist (dir "twitRss")) $ + userScriptProperty "joey" + [ "cd " ++ dir + , "ghc --make twitRss" + ] + `requires` Apt.installed + [ "libghc-xml-dev" + , "libghc-feed-dev" + , "libghc-tagsoup-dev" + ] + , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" + , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" + ] + where + dir = "/srv/web/tmp.kitenet.net/twitrss" + crontime = "15 * * * *" + feed url desc = Cron.job desc crontime "joey" dir $ + "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") + +ircBouncer :: Property +ircBouncer = propertyList "IRC bouncer" + [ Apt.installed ["znc"] + , User.accountFor "znc" + , File.hasPrivContent conf + , File.ownerGroup conf "znc" "znc" + , Cron.job "znconboot" "@reboot" "znc" "~" "znc" + , Cron.job "zncrunning" "@hourly" "znc" "~" "znc || true" + ] + where + conf = "/home/znc/.znc/configs/znc.conf" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs new file mode 100644 index 00000000..a4f87678 --- /dev/null +++ b/src/Propellor/Property/Ssh.hs @@ -0,0 +1,152 @@ +module Propellor.Property.Ssh ( + setSshdConfig, + permitRootLogin, + passwordAuthentication, + hasAuthorizedKeys, + restartSshd, + randomHostKeys, + hostKey, + keyImported, + knownHost, + authorizedKeys +) where + +import Propellor +import qualified Propellor.Property.File as File +import Propellor.Property.User +import Utility.SafeCommand +import Utility.FileMode + +import System.PosixCompat + +sshBool :: Bool -> String +sshBool True = "yes" +sshBool False = "no" + +sshdConfig :: FilePath +sshdConfig = "/etc/ssh/sshd_config" + +setSshdConfig :: String -> Bool -> Property +setSshdConfig setting allowed = combineProperties "sshd config" + [ sshdConfig `File.lacksLine` (sshline $ not allowed) + , sshdConfig `File.containsLine` (sshline allowed) + ] + `onChange` restartSshd + `describe` unwords [ "ssh config:", setting, sshBool allowed ] + where + sshline v = setting ++ " " ++ sshBool v + +permitRootLogin :: Bool -> Property +permitRootLogin = setSshdConfig "PermitRootLogin" + +passwordAuthentication :: Bool -> Property +passwordAuthentication = setSshdConfig "PasswordAuthentication" + +dotDir :: UserName -> IO FilePath +dotDir user = do + h <- homedir user + return $ h ".ssh" + +dotFile :: FilePath -> UserName -> IO FilePath +dotFile f user = do + d <- dotDir user + return $ d f + +hasAuthorizedKeys :: UserName -> IO Bool +hasAuthorizedKeys = go <=< dotFile "authorized_keys" + where + go f = not . null <$> catchDefaultIO "" (readFile f) + +restartSshd :: Property +restartSshd = cmdProperty "service" ["ssh", "restart"] + +-- | Blows away existing host keys and make new ones. +-- Useful for systems installed from an image that might reuse host keys. +-- A flag file is used to only ever do this once. +randomHostKeys :: Property +randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" + `onChange` restartSshd + where + prop = property "ssh random host keys" $ do + void $ liftIO $ boolSystem "sh" + [ Param "-c" + , Param "rm -f /etc/ssh/ssh_host_*" + ] + ensureProperty $ + cmdProperty "/var/lib/dpkg/info/openssh-server.postinst" + ["configure"] + +-- | Sets ssh host keys from the site's PrivData. +-- +-- (Uses a null username for host keys.) +hostKey :: SshKeyType -> Property +hostKey keytype = combineProperties desc + [ property desc (install writeFile (SshPubKey keytype "") ".pub") + , property desc (install writeFileProtected (SshPrivKey keytype "") "") + ] + `onChange` restartSshd + where + desc = "known ssh host key (" ++ fromKeyType keytype ++ ")" + install writer p ext = withPrivData p $ \key -> do + let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext + s <- liftIO $ readFileStrict f + if s == key + then noChange + else makeChange $ writer f key + +-- | Sets up a user with a ssh private key and public key pair +-- from the site's PrivData. +keyImported :: SshKeyType -> UserName -> Property +keyImported keytype user = combineProperties desc + [ property desc (install writeFile (SshPubKey keytype user) ".pub") + , property desc (install writeFileProtected (SshPrivKey keytype user) "") + ] + where + desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" + install writer p ext = do + f <- liftIO $ keyfile ext + ifM (liftIO $ doesFileExist f) + ( noChange + , ensureProperty $ combineProperties desc + [ property desc $ + withPrivData p $ \key -> makeChange $ + writer f key + , File.ownerGroup f user user + ] + ) + keyfile ext = do + home <- homeDirectory <$> getUserEntryForName user + return $ home ".ssh" "id_" ++ fromKeyType keytype ++ ext + +fromKeyType :: SshKeyType -> String +fromKeyType SshRsa = "rsa" +fromKeyType SshDsa = "dsa" +fromKeyType SshEcdsa = "ecdsa" +fromKeyType SshEd25519 = "ed25519" + +-- | Puts some host's ssh public key into the known_hosts file for a user. +knownHost :: [Host] -> HostName -> UserName -> Property +knownHost hosts hn user = property desc $ + go =<< fromHost hosts hn getSshPubKey + where + desc = user ++ " knows ssh key for " ++ hn + go (Just (Just k)) = do + f <- liftIO $ dotFile "known_hosts" user + ensureProperty $ combineProperties desc + [ File.dirExists (takeDirectory f) + , f `File.containsLine` (hn ++ " " ++ k) + , File.ownerGroup f user user + ] + go _ = do + warningMessage $ "no configred sshPubKey for " ++ hn + return FailedChange + +-- | Makes a user have authorized_keys from the PrivData +authorizedKeys :: UserName -> Property +authorizedKeys user = property (user ++ " has authorized_keys") $ + withPrivData (SshAuthorizedKeys user) $ \v -> do + f <- liftIO $ dotFile "authorized_keys" user + liftIO $ do + createDirectoryIfMissing True (takeDirectory f) + writeFileProtected f v + ensureProperty $ File.ownerGroup f user user diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs new file mode 100644 index 00000000..68b56608 --- /dev/null +++ b/src/Propellor/Property/Sudo.hs @@ -0,0 +1,32 @@ +module Propellor.Property.Sudo where + +import Data.List + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +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 :: UserName -> Property +enabledFor user = property desc go `requires` Apt.installed ["sudo"] + where + go = do + locked <- liftIO $ isLockedPassword user + ensureProperty $ + fileProperty desc + (modify locked . filter (wanted locked)) + "/etc/sudoers" + desc = user ++ " is sudoer" + sudobaseline = user ++ " ALL=(ALL:ALL)" + sudoline True = sudobaseline ++ " NOPASSWD:ALL" + sudoline False = sudobaseline ++ " ALL" + wanted locked l + -- TOOD: Full sudoers file format parse.. + | not (sudobaseline `isPrefixOf` l) = True + | "NOPASSWD" `isInfixOf` l = locked + | otherwise = True + modify locked ls + | sudoline locked `elem` ls = ls + | otherwise = ls ++ [sudoline locked] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs new file mode 100644 index 00000000..78e35c89 --- /dev/null +++ b/src/Propellor/Property/Tor.hs @@ -0,0 +1,19 @@ +module Propellor.Property.Tor where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +isBridge :: Property +isBridge = setup `requires` Apt.installed ["tor"] + `describe` "tor bridge" + where + setup = "/etc/tor/torrc" `File.hasContent` + [ "SocksPort 0" + , "ORPort 443" + , "BridgeRelay 1" + , "Exitpolicy reject *:*" + ] `onChange` restartTor + +restartTor :: Property +restartTor = cmdProperty "service" ["tor", "restart"] diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs new file mode 100644 index 00000000..eef2a57e --- /dev/null +++ b/src/Propellor/Property/User.hs @@ -0,0 +1,61 @@ +module Propellor.Property.User where + +import System.Posix + +import Propellor + +data Eep = YesReallyDeleteHome + +accountFor :: UserName -> Property +accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" + [ "--disabled-password" + , "--gecos", "" + , user + ] + `describe` ("account for " ++ user) + +-- | Removes user home directory!! Use with caution. +nuked :: UserName -> Eep -> Property +nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" + [ "-r" + , user + ] + `describe` ("nuked user " ++ user) + +-- | Only ensures that the user has some password set. It may or may +-- not be the password from the PrivData. +hasSomePassword :: UserName -> Property +hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $ + hasPassword user + +hasPassword :: UserName -> Property +hasPassword user = property (user ++ " has password") $ + withPrivData (Password user) $ \password -> makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "chpasswd" []) $ \h -> do + hPutStrLn h $ user ++ ":" ++ password + hClose h + +lockedPassword :: UserName -> Property +lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" + [ "--lock" + , user + ] + `describe` ("locked " ++ user ++ " password") + +data PasswordStatus = NoPassword | LockedPassword | HasPassword + deriving (Eq) + +getPasswordStatus :: UserName -> IO PasswordStatus +getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] + where + parse (_:"L":_) = LockedPassword + parse (_:"NP":_) = NoPassword + parse (_:"P":_) = HasPassword + parse _ = NoPassword + +isLockedPassword :: UserName -> IO Bool +isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user + +homedir :: UserName -> IO FilePath +homedir user = homeDirectory <$> getUserEntryForName user -- cgit v1.2.3