summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Apache.hs62
-rw-r--r--src/Propellor/Property/Apt.hs256
-rw-r--r--src/Propellor/Property/Cmd.hs49
-rw-r--r--src/Propellor/Property/Cron.hs49
-rw-r--r--src/Propellor/Property/Dns.hs405
-rw-r--r--src/Propellor/Property/Docker.hs456
-rw-r--r--src/Propellor/Property/Docker/Shim.hs61
-rw-r--r--src/Propellor/Property/File.hs94
-rw-r--r--src/Propellor/Property/Git.hs93
-rw-r--r--src/Propellor/Property/Gpg.hs41
-rw-r--r--src/Propellor/Property/Hostname.hs33
-rw-r--r--src/Propellor/Property/Network.hs30
-rw-r--r--src/Propellor/Property/Obnam.hs155
-rw-r--r--src/Propellor/Property/OpenId.hs29
-rw-r--r--src/Propellor/Property/Postfix.hs25
-rw-r--r--src/Propellor/Property/Reboot.hs7
-rw-r--r--src/Propellor/Property/Scheduled.hs67
-rw-r--r--src/Propellor/Property/Service.hs31
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs57
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs34
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs314
-rw-r--r--src/Propellor/Property/Ssh.hs152
-rw-r--r--src/Propellor/Property/Sudo.hs32
-rw-r--r--src/Propellor/Property/Tor.hs19
-rw-r--r--src/Propellor/Property/User.hs61
25 files changed, 2612 insertions, 0 deletions
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: <number><optional unit>, 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 </dev/null fixes an intermittent
+ -- "fatal: read error: Bad file descriptor"
+ -- when run across ssh with propellor --spin
+ [ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
+ , Just $ "cd " ++ shellEscape dir
+ , ("git checkout " ++) <$> 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 ++ "/"
+ , " <Directory " ++ 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"
+ , " </Directory>"
+ ]
+ ]
+ 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/"
+ , " <Directory /srv/web/git.kitenet.net/>"
+ , " Options Indexes ExecCGI FollowSymlinks"
+ , " AllowOverride None"
+ , " AddHandler cgi-script .cgi"
+ , " DirectoryIndex index.cgi"
+ , " </Directory>"
+ , ""
+ , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"
+ , " <Directory /usr/lib/cgi-bin>"
+ , " SetHandler cgi-script"
+ , " Options ExecCGI"
+ , " </Directory>"
+ ]
+
+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
+ , " <Directory /srv/web/"++hn++">"
+ , " Options FollowSymLinks"
+ , " AllowOverride None"
+ , " </Directory>"
+ , " <Directory /srv/web/"++hn++">"
+ , " Options Indexes FollowSymLinks ExecCGI"
+ , " AllowOverride None"
+ , " AddHandler cgi-script .cgi"
+ , " DirectoryIndex index.html index.cgi"
+ , " Order allow,deny"
+ , " allow from all"
+ , " </Directory>"
+ ]
+
+apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
+apachecfg hn withssl middle
+ | withssl = vhost False ++ vhost True
+ | otherwise = vhost False
+ where
+ vhost ssl =
+ [ "<VirtualHost *:"++show port++">"
+ , " 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"
+ , " "
+ , " <Directory \"/usr/share/apache2/icons\">"
+ , " Options Indexes MultiViews"
+ , " AllowOverride None"
+ , " Order allow,deny"
+ , " Allow from all"
+ , " </Directory>"
+ , "</VirtualHost>"
+ ]
+ 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