From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- Propellor/Property/Apache.hs | 62 --- Propellor/Property/Apt.hs | 256 ------------ Propellor/Property/Cmd.hs | 49 --- Propellor/Property/Cron.hs | 49 --- Propellor/Property/Dns.hs | 405 ------------------ Propellor/Property/Docker.hs | 456 --------------------- Propellor/Property/Docker/Shim.hs | 61 --- Propellor/Property/File.hs | 94 ----- Propellor/Property/Git.hs | 93 ----- Propellor/Property/Gpg.hs | 41 -- Propellor/Property/Hostname.hs | 33 -- Propellor/Property/Network.hs | 30 -- Propellor/Property/Obnam.hs | 155 ------- Propellor/Property/OpenId.hs | 29 -- Propellor/Property/Postfix.hs | 25 -- Propellor/Property/Reboot.hs | 7 - Propellor/Property/Scheduled.hs | 67 --- Propellor/Property/Service.hs | 31 -- Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 57 --- Propellor/Property/SiteSpecific/GitHome.hs | 34 -- Propellor/Property/SiteSpecific/JoeySites.hs | 314 -------------- Propellor/Property/Ssh.hs | 152 ------- Propellor/Property/Sudo.hs | 32 -- Propellor/Property/Tor.hs | 19 - Propellor/Property/User.hs | 61 --- 25 files changed, 2612 deletions(-) delete mode 100644 Propellor/Property/Apache.hs delete mode 100644 Propellor/Property/Apt.hs delete mode 100644 Propellor/Property/Cmd.hs delete mode 100644 Propellor/Property/Cron.hs delete mode 100644 Propellor/Property/Dns.hs delete mode 100644 Propellor/Property/Docker.hs delete mode 100644 Propellor/Property/Docker/Shim.hs delete mode 100644 Propellor/Property/File.hs delete mode 100644 Propellor/Property/Git.hs delete mode 100644 Propellor/Property/Gpg.hs delete mode 100644 Propellor/Property/Hostname.hs delete mode 100644 Propellor/Property/Network.hs delete mode 100644 Propellor/Property/Obnam.hs delete mode 100644 Propellor/Property/OpenId.hs delete mode 100644 Propellor/Property/Postfix.hs delete mode 100644 Propellor/Property/Reboot.hs delete mode 100644 Propellor/Property/Scheduled.hs delete mode 100644 Propellor/Property/Service.hs delete mode 100644 Propellor/Property/SiteSpecific/GitAnnexBuilder.hs delete mode 100644 Propellor/Property/SiteSpecific/GitHome.hs delete mode 100644 Propellor/Property/SiteSpecific/JoeySites.hs delete mode 100644 Propellor/Property/Ssh.hs delete mode 100644 Propellor/Property/Sudo.hs delete mode 100644 Propellor/Property/Tor.hs delete mode 100644 Propellor/Property/User.hs (limited to 'Propellor/Property') diff --git a/Propellor/Property/Apache.hs b/Propellor/Property/Apache.hs deleted file mode 100644 index cf3e62cc..00000000 --- a/Propellor/Property/Apache.hs +++ /dev/null @@ -1,62 +0,0 @@ -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/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs deleted file mode 100644 index 7329c7a8..00000000 --- a/Propellor/Property/Apt.hs +++ /dev/null @@ -1,256 +0,0 @@ -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/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs deleted file mode 100644 index bcd08246..00000000 --- a/Propellor/Property/Cmd.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs deleted file mode 100644 index 5b070eff..00000000 --- a/Propellor/Property/Cron.hs +++ /dev/null @@ -1,49 +0,0 @@ -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/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs deleted file mode 100644 index 5c3162cb..00000000 --- a/Propellor/Property/Dns.hs +++ /dev/null @@ -1,405 +0,0 @@ -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/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs deleted file mode 100644 index 09d7d6a4..00000000 --- a/Propellor/Property/Docker.hs +++ /dev/null @@ -1,456 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- | Docker support for propellor --- --- The existance of a docker container is just another Property of a system, --- which propellor can set up. See config.hs for an example. - -module Propellor.Property.Docker where - -import Propellor -import Propellor.SimpleSh -import Propellor.Types.Attr -import qualified Propellor.Property.File as File -import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Docker.Shim as Shim -import Utility.SafeCommand -import Utility.Path - -import Control.Concurrent.Async -import System.Posix.Directory -import System.Posix.Process -import Data.List -import Data.List.Utils - --- | Configures docker with an authentication file, so that images can be --- pushed to index.docker.io. -configured :: Property -configured = property "docker configured" go `requires` installed - where - go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ - "/root/.dockercfg" `File.hasContent` (lines cfg) - -installed :: Property -installed = Apt.installed ["docker.io"] - --- | A short descriptive name for a container. --- Should not contain whitespace or other unusual characters, --- only [a-zA-Z0-9_-] are allowed -type ContainerName = String - --- | Starts accumulating the properties of a Docker container. --- --- > container "web-server" "debian" --- > & publish "80:80" --- > & Apt.installed {"apache2"] --- > & ... -container :: ContainerName -> Image -> Host -container cn image = Host [] (\_ -> attr) - where - attr = (newAttr (cn2hn cn)) { _dockerImage = Just image } - -cn2hn :: ContainerName -> HostName -cn2hn cn = cn ++ ".docker" - --- | Ensures that a docker container is set up and running. The container --- has its own Properties which are handled by running propellor --- inside the container. --- --- Reverting this property ensures that the container is stopped and --- removed. -docked - :: [Host] - -> ContainerName - -> RevertableProperty -docked hosts cn = RevertableProperty (go "docked" setup) (go "undocked" teardown) - where - go desc a = property (desc ++ " " ++ cn) $ do - hn <- getHostName - let cid = ContainerId hn cn - ensureProperties [findContainer hosts cid cn $ a cid] - - setup cid (Container image runparams) = - provisionContainer cid - `requires` - runningContainer cid image runparams - `requires` - installed - - teardown cid (Container image _runparams) = - combineProperties ("undocked " ++ fromContainerId cid) - [ stoppedContainer cid - , property ("cleaned up " ++ fromContainerId cid) $ - liftIO $ report <$> mapM id - [ removeContainer cid - , removeImage image - ] - ] - -findContainer - :: [Host] - -> ContainerId - -> ContainerName - -> (Container -> Property) - -> Property -findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of - Nothing -> cantfind - Just h -> maybe cantfind mk (mkContainer cid h) - where - cantfind = containerDesc cid $ property "" $ do - liftIO $ warningMessage $ - "missing definition for docker container \"" ++ cn2hn cn - return FailedChange - -mkContainer :: ContainerId -> Host -> Maybe Container -mkContainer cid@(ContainerId hn _cn) h = Container - <$> _dockerImage attr - <*> pure (map (\a -> a hn) (_dockerRunParams attr)) - where - attr = hostAttr h' - h' = h - -- expose propellor directory inside the container - & volume (localdir++":"++localdir) - -- name the container in a predictable way so we - -- and the user can easily find it later - & name (fromContainerId cid) - --- | Causes *any* docker images that are not in use by running containers to --- be deleted. And deletes any containers that propellor has set up --- before that are not currently running. Does not delete any containers --- that were not set up using propellor. --- --- Generally, should come after the properties for the desired containers. -garbageCollected :: Property -garbageCollected = propertyList "docker garbage collected" - [ gccontainers - , gcimages - ] - where - gccontainers = property "docker containers garbage collected" $ - liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) - gcimages = property "docker images garbage collected" $ do - liftIO $ report <$> (mapM removeImage =<< listImages) - -data Container = Container Image [RunParam] - --- | Parameters to pass to `docker run` when creating a container. -type RunParam = String - --- | A docker image, that can be used to run a container. -type Image = String - --- | Set custom dns server for container. -dns :: String -> Property -dns = runProp "dns" - --- | Set container host name. -hostname :: String -> Property -hostname = runProp "hostname" - --- | Set name for container. (Normally done automatically.) -name :: String -> Property -name = runProp "name" - --- | Publish a container's port to the host --- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Property -publish = runProp "publish" - --- | Username or UID for container. -user :: String -> Property -user = runProp "user" - --- | Mount a volume --- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] --- With just a directory, creates a volume in the container. -volume :: String -> Property -volume = runProp "volume" - --- | Mount a volume from the specified container into the current --- container. -volumes_from :: ContainerName -> Property -volumes_from cn = genProp "volumes-from" $ \hn -> - fromContainerId (ContainerId hn cn) - --- | Work dir inside the container. -workdir :: String -> Property -workdir = runProp "workdir" - --- | Memory limit for container. ---Format: , where unit = b, k, m or g -memory :: String -> Property -memory = runProp "memory" - --- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property -link linkwith calias = genProp "link" $ \hn -> - fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias - --- | A short alias for a linked container. --- Each container has its own alias namespace. -type ContainerAlias = String - --- | A container is identified by its name, and the host --- on which it's deployed. -data ContainerId = ContainerId HostName ContainerName - deriving (Eq, Read, Show) - --- | Two containers with the same ContainerIdent were started from --- the same base image (possibly a different version though), and --- with the same RunParams. -data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] - deriving (Read, Show, Eq) - -ident2id :: ContainerIdent -> ContainerId -ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn - -toContainerId :: String -> Maybe ContainerId -toContainerId s - | myContainerSuffix `isSuffixOf` s = case separate (== '.') (desuffix s) of - (cn, hn) - | null hn || null cn -> Nothing - | otherwise -> Just $ ContainerId hn cn - | otherwise = Nothing - where - desuffix = reverse . drop len . reverse - len = length myContainerSuffix - -fromContainerId :: ContainerId -> String -fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix - -containerHostName :: ContainerId -> HostName -containerHostName (ContainerId _ cn) = cn2hn cn - -myContainerSuffix :: String -myContainerSuffix = ".propellor" - -containerDesc :: ContainerId -> Property -> Property -containerDesc cid p = p `describe` desc - where - desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p - -runningContainer :: ContainerId -> Image -> [RunParam] -> Property -runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do - l <- liftIO $ listContainers RunningContainers - if cid `elem` l - then do - -- Check if the ident has changed; if so the - -- parameters of the container differ and it must - -- be restarted. - runningident <- liftIO $ getrunningident - if runningident == Just ident - then noChange - else do - void $ liftIO $ stopContainer cid - restartcontainer - else ifM (liftIO $ elem cid <$> listContainers AllContainers) - ( restartcontainer - , go image - ) - where - ident = ContainerIdent image hn cn runps - - restartcontainer = do - oldimage <- liftIO $ fromMaybe image <$> commitContainer cid - void $ liftIO $ removeContainer cid - go oldimage - - getrunningident :: IO (Maybe ContainerIdent) - getrunningident = simpleShClient (namedPipe cid) "cat" [propellorIdent] $ \rs -> do - let !v = extractident rs - return v - - extractident :: [Resp] -> Maybe ContainerIdent - extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout - - go img = do - liftIO $ do - clearProvisionedFlag cid - createDirectoryIfMissing True (takeDirectory $ identFile cid) - shim <- liftIO $ Shim.setup (localdir "propellor") (localdir shimdir cid) - liftIO $ writeFile (identFile cid) (show ident) - ensureProperty $ boolProperty "run" $ runContainer img - (runps ++ ["-i", "-d", "-t"]) - [shim, "--docker", fromContainerId cid] - --- | Called when propellor is running inside a docker container. --- The string should be the container's ContainerId. --- --- This process is effectively init inside the container. --- It even needs to wait on zombie processes! --- --- Fork a thread to run the SimpleSh server in the background. --- In the foreground, run an interactive bash (or sh) shell, --- so that the user can interact with it when attached to the container. --- --- When the system reboots, docker restarts the container, and this is run --- again. So, to make the necessary services get started on boot, this needs --- to provision the container then. However, if the container is already --- being provisioned by the calling propellor, it would be redundant and --- problimatic to also provisoon it here. --- --- The solution is a flag file. If the flag file exists, then the container --- was already provisioned. So, it must be a reboot, and time to provision --- again. If the flag file doesn't exist, don't provision here. -chain :: String -> IO () -chain s = case toContainerId s of - Nothing -> error $ "Invalid ContainerId: " ++ s - Just cid -> do - changeWorkingDirectory localdir - writeFile propellorIdent . show =<< readIdentFile cid - -- Run boot provisioning before starting simpleSh, - -- to avoid ever provisioning twice at the same time. - whenM (checkProvisionedFlag cid) $ do - let shim = Shim.file (localdir "propellor") (localdir shimdir cid) - unlessM (boolSystem shim [Param "--continue", Param $ show $ Chain $ containerHostName cid]) $ - warningMessage "Boot provision failed!" - void $ async $ job reapzombies - void $ async $ job $ simpleSh $ namedPipe cid - job $ do - void $ tryIO $ ifM (inPath "bash") - ( boolSystem "bash" [Param "-l"] - , boolSystem "/bin/sh" [] - ) - putStrLn "Container is still running. Press ^P^Q to detach." - where - job = forever . void . tryIO - reapzombies = void $ getAnyProcessStatus True False - --- | Once a container is running, propellor can be run inside --- it to provision it. --- --- Note that there is a race here, between the simplesh --- server starting up in the container, and this property --- being run. So, retry connections to the client for up to --- 1 minute. -provisionContainer :: ContainerId -> Property -provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do - let shim = Shim.file (localdir "propellor") (localdir shimdir cid) - r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing) - when (r /= FailedChange) $ - setProvisionedFlag cid - return r - where - params = ["--continue", show $ Chain $ containerHostName cid] - - go lastline (v:rest) = case v of - StdoutLine s -> do - maybe noop putStrLn lastline - hFlush stdout - go (Just s) rest - StderrLine s -> do - maybe noop putStrLn lastline - hFlush stdout - hPutStrLn stderr s - hFlush stderr - go Nothing rest - Done -> ret lastline - go lastline [] = ret lastline - - ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline - -stopContainer :: ContainerId -> IO Bool -stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] - -stoppedContainer :: ContainerId -> Property -stoppedContainer cid = containerDesc cid $ property desc $ - ifM (liftIO $ elem cid <$> listContainers RunningContainers) - ( liftIO cleanup `after` ensureProperty - (boolProperty desc $ stopContainer cid) - , return NoChange - ) - where - desc = "stopped" - cleanup = do - nukeFile $ namedPipe cid - nukeFile $ identFile cid - removeDirectoryRecursive $ shimdir cid - clearProvisionedFlag cid - -removeContainer :: ContainerId -> IO Bool -removeContainer cid = catchBoolIO $ - snd <$> processTranscript dockercmd ["rm", fromContainerId cid ] Nothing - -removeImage :: Image -> IO Bool -removeImage image = catchBoolIO $ - snd <$> processTranscript dockercmd ["rmi", image ] Nothing - -runContainer :: Image -> [RunParam] -> [String] -> IO Bool -runContainer image ps cmd = boolSystem dockercmd $ map Param $ - "run" : (ps ++ image : cmd) - -commitContainer :: ContainerId -> IO (Maybe Image) -commitContainer cid = catchMaybeIO $ - takeWhile (/= '\n') - <$> readProcess dockercmd ["commit", fromContainerId cid] - -data ContainerFilter = RunningContainers | AllContainers - deriving (Eq) - --- | Only lists propellor managed containers. -listContainers :: ContainerFilter -> IO [ContainerId] -listContainers status = - catMaybes . map toContainerId . concat . map (split ",") - . catMaybes . map (lastMaybe . words) . lines - <$> readProcess dockercmd ps - where - ps - | status == AllContainers = baseps ++ ["--all"] - | otherwise = baseps - baseps = ["ps", "--no-trunc"] - -listImages :: IO [Image] -listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] - -runProp :: String -> RunParam -> Property -runProp field val = pureAttrProperty (param) $ \attr -> - attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] } - where - param = field++"="++val - -genProp :: String -> (HostName -> RunParam) -> Property -genProp field mkval = pureAttrProperty field $ \attr -> - attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] } - --- | The ContainerIdent of a container is written to --- /.propellor-ident inside it. This can be checked to see if --- the container has the same ident later. -propellorIdent :: FilePath -propellorIdent = "/.propellor-ident" - --- | Named pipe used for communication with the container. -namedPipe :: ContainerId -> FilePath -namedPipe cid = "docker" fromContainerId cid - -provisionedFlag :: ContainerId -> FilePath -provisionedFlag cid = "docker" fromContainerId cid ++ ".provisioned" - -clearProvisionedFlag :: ContainerId -> IO () -clearProvisionedFlag = nukeFile . provisionedFlag - -setProvisionedFlag :: ContainerId -> IO () -setProvisionedFlag cid = do - createDirectoryIfMissing True (takeDirectory (provisionedFlag cid)) - writeFile (provisionedFlag cid) "1" - -checkProvisionedFlag :: ContainerId -> IO Bool -checkProvisionedFlag = doesFileExist . provisionedFlag - -shimdir :: ContainerId -> FilePath -shimdir cid = "docker" fromContainerId cid ++ ".shim" - -identFile :: ContainerId -> FilePath -identFile cid = "docker" fromContainerId cid ++ ".ident" - -readIdentFile :: ContainerId -> IO ContainerIdent -readIdentFile cid = fromMaybe (error "bad ident in identFile") - . readish <$> readFile (identFile cid) - -dockercmd :: String -dockercmd = "docker.io" - -report :: [Bool] -> Result -report rmed - | or rmed = MadeChange - | otherwise = NoChange - diff --git a/Propellor/Property/Docker/Shim.hs b/Propellor/Property/Docker/Shim.hs deleted file mode 100644 index c2f35d0c..00000000 --- a/Propellor/Property/Docker/Shim.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | 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/Propellor/Property/File.hs b/Propellor/Property/File.hs deleted file mode 100644 index 0b060177..00000000 --- a/Propellor/Property/File.hs +++ /dev/null @@ -1,94 +0,0 @@ -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/Propellor/Property/Git.hs b/Propellor/Property/Git.hs deleted file mode 100644 index e5df7e48..00000000 --- a/Propellor/Property/Git.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Propellor.Property.Git where - -import Propellor -import Propellor.Property.File -import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.Service as Service -import Utility.SafeCommand - -import Data.List - --- | Exports all git repos in a directory (that user nobody can read) --- using git-daemon, run from inetd. --- --- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty -daemonRunning exportdir = RevertableProperty setup unsetup - where - setup = containsLine conf (mkl "tcp4") - `requires` - containsLine conf (mkl "tcp6") - `requires` - dirExists exportdir - `requires` - Apt.serviceInstalledRunning "openbsd-inetd" - `onChange` - Service.running "openbsd-inetd" - `describe` ("git-daemon exporting " ++ exportdir) - unsetup = lacksLine conf (mkl "tcp4") - `requires` - lacksLine conf (mkl "tcp6") - `onChange` - Service.reloaded "openbsd-inetd" - - conf = "/etc/inetd.conf" - - mkl tcpv = intercalate "\t" - [ "git" - , "stream" - , tcpv - , "nowait" - , "nobody" - , "/usr/bin/git" - , "git" - , "daemon" - , "--inetd" - , "--export-all" - , "--base-path=" ++ exportdir - , exportdir - ] - -installed :: Property -installed = Apt.installed ["git"] - -type RepoUrl = String - -type Branch = String - --- | Specified git repository is cloned to the specified directory. --- --- If the firectory exists with some other content, it will be recursively --- deleted. --- --- A branch can be specified, to check out. -cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property -cloned owner url dir mbranch = check originurl (property desc checkout) - `requires` installed - where - desc = "git cloned " ++ url ++ " to " ++ dir - gitconfig = dir ".git/config" - originurl = ifM (doesFileExist gitconfig) - ( do - v <- catchDefaultIO Nothing $ headMaybe . lines <$> - readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"] - return (v /= Just url) - , return True - ) - checkout = do - liftIO $ do - whenM (doesDirectoryExist dir) $ - removeDirectoryRecursive dir - createDirectoryIfMissing True (takeDirectory dir) - ensureProperty $ userScriptProperty owner $ catMaybes - -- The mbranch - -- In case this repo is exposted via the web, - -- although the hook to do this ongoing is not - -- installed here. - , Just "git update-server-info" - ] diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs deleted file mode 100644 index 64ea9fea..00000000 --- a/Propellor/Property/Gpg.hs +++ /dev/null @@ -1,41 +0,0 @@ -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/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs deleted file mode 100644 index 031abb9d..00000000 --- a/Propellor/Property/Hostname.hs +++ /dev/null @@ -1,33 +0,0 @@ -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/Propellor/Property/Network.hs b/Propellor/Property/Network.hs deleted file mode 100644 index 6009778a..00000000 --- a/Propellor/Property/Network.hs +++ /dev/null @@ -1,30 +0,0 @@ -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/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs deleted file mode 100644 index 32374b57..00000000 --- a/Propellor/Property/Obnam.hs +++ /dev/null @@ -1,155 +0,0 @@ -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/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs deleted file mode 100644 index 051d6425..00000000 --- a/Propellor/Property/OpenId.hs +++ /dev/null @@ -1,29 +0,0 @@ -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/Propellor/Property/Postfix.hs b/Propellor/Property/Postfix.hs deleted file mode 100644 index 9fa4a2c3..00000000 --- a/Propellor/Property/Postfix.hs +++ /dev/null @@ -1,25 +0,0 @@ -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/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs deleted file mode 100644 index 25e53159..00000000 --- a/Propellor/Property/Reboot.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Propellor.Property.Reboot where - -import Propellor - -now :: Property -now = cmdProperty "reboot" [] - `describe` "reboot now" diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs deleted file mode 100644 index f2911e50..00000000 --- a/Propellor/Property/Scheduled.hs +++ /dev/null @@ -1,67 +0,0 @@ -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/Propellor/Property/Service.hs b/Propellor/Property/Service.hs deleted file mode 100644 index 14e769d0..00000000 --- a/Propellor/Property/Service.hs +++ /dev/null @@ -1,31 +0,0 @@ -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/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs deleted file mode 100644 index 677aa760..00000000 --- a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ /dev/null @@ -1,57 +0,0 @@ -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/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs deleted file mode 100644 index 6ed02146..00000000 --- a/Propellor/Property/SiteSpecific/GitHome.hs +++ /dev/null @@ -1,34 +0,0 @@ -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/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs deleted file mode 100644 index 28b3dffd..00000000 --- a/Propellor/Property/SiteSpecific/JoeySites.hs +++ /dev/null @@ -1,314 +0,0 @@ --- | Specific configuation for Joey Hess's sites. Probably not useful to --- others except as an example. - -module Propellor.Property.SiteSpecific.JoeySites where - -import Propellor -import qualified Propellor.Property.Apt as Apt -import qualified Propellor.Property.File as File -import qualified Propellor.Property.Gpg as Gpg -import qualified Propellor.Property.Ssh as Ssh -import qualified Propellor.Property.Git as Git -import qualified Propellor.Property.Cron as Cron -import qualified Propellor.Property.Service as Service -import qualified Propellor.Property.User as User -import qualified Propellor.Property.Obnam as Obnam -import qualified Propellor.Property.Apache as Apache -import Utility.SafeCommand -import Utility.FileMode - -import Data.List -import System.Posix.Files - -oldUseNetServer :: [Host] -> Property -oldUseNetServer hosts = propertyList ("olduse.net server") - [ oldUseNetInstalled "oldusenet-server" - , Obnam.latestVersion - , Obnam.backup datadir "33 4 * * *" - [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" - , "--client-name=spool" - ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ - property "olduse.net spool in place" $ makeChange $ do - removeDirectoryRecursive newsspool - createSymbolicLink (datadir "news") newsspool - , Apt.installed ["leafnode"] - , "/etc/news/leafnode/config" `File.hasContent` - [ "# olduse.net configuration (deployed by propellor)" - , "expire = 1000000" -- no expiry via texpire - , "server = " -- no upstream server - , "debugmode = 1" - , "allowSTRANGERS = 42" -- lets anyone connect - , "nopost = 1" -- no new posting (just gather them) - ] - , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" - , Apt.serviceInstalledRunning "openbsd-inetd" - , File.notPresent "/etc/cron.daily/leafnode" - , File.notPresent "/etc/cron.d/leafnode" - , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" - [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" - , "find -type d -empty | xargs --no-run-if-empty rmdir" - ] - , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ - "/usr/bin/uucp " ++ datadir - , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False - [ " DocumentRoot " ++ datadir ++ "/" - , " " - , " Options Indexes FollowSymlinks" - , " AllowOverride None" - -- I had this in the file before. - -- This may be needed by a newer version of apache? - --, " Require all granted" - , " " - ] - ] - where - newsspool = "/var/spool/news" - datadir = "/var/spool/oldusenet" - -oldUseNetShellBox :: Property -oldUseNetShellBox = oldUseNetInstalled "oldusenet" - -oldUseNetInstalled :: Apt.Package -> Property -oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ - propertyList ("olduse.net " ++ pkg) - [ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") - `describe` "olduse.net build deps" - , scriptProperty - [ "rm -rf /root/tmp/oldusenet" -- idenpotency - , "git clone git://olduse.net/ /root/tmp/oldusenet/source" - , "cd /root/tmp/oldusenet/source/" - , "dpkg-buildpackage -us -uc" - , "dpkg -i ../" ++ pkg ++ "_*.deb || true" - , "apt-get -fy install" -- dependencies - , "rm -rf /root/tmp/oldusenet" - ] `describe` "olduse.net built" - ] - - -kgbServer :: Property -kgbServer = withOS desc $ \o -> case o of - (Just (System (Debian Unstable) _)) -> - ensureProperty $ propertyList desc - [ Apt.serviceInstalledRunning "kgb-bot" - , File.hasPrivContent "/etc/kgb-bot/kgb.conf" - `onChange` Service.restarted "kgb-bot" - , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" - `describe` "kgb bot enabled" - `onChange` Service.running "kgb-bot" - ] - _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" - where - desc = "kgb.kitenet.net setup" - -mumbleServer :: [Host] -> Property -mumbleServer hosts = combineProperties "mumble.debian.net" - [ Apt.serviceInstalledRunning "mumble-server" - , Obnam.latestVersion - , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" - [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam" - , "--client-name=mumble" - ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" - `requires` Ssh.knownHost hosts "turtle.kitenet.net" "root" - , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] - ] - -obnamLowMem :: Property -obnamLowMem = combineProperties "obnam tuned for low memory use" - [ Obnam.latestVersion - , "/etc/obnam.conf" `File.containsLines` - [ "[config]" - , "# Suggested by liw to keep Obnam memory consumption down (at some speed cost)." - , "upload-queue-size = 128" - , "lru-size = 128" - ] - ] - --- git.kitenet.net and git.joeyh.name -gitServer :: [Host] -> Property -gitServer hosts = propertyList "git.kitenet.net setup" - [ Obnam.latestVersion - , Obnam.backup "/srv/git" "33 3 * * *" - [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" - , "--encrypt-with=1B169BE1" - , "--client-name=wren" - ] Obnam.OnlyClient - `requires` Gpg.keyImported "1B169BE1" "root" - `requires` Ssh.keyImported SshRsa "root" - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - `requires` Ssh.authorizedKeys "family" - `requires` User.accountFor "family" - , Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"] - , Apt.installedBackport ["git-annex"] - , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" - , toProp $ Git.daemonRunning "/srv/git" - , "/etc/gitweb.conf" `File.containsLines` - [ "$projectroot = '/srv/git';" - , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" - , "# disable snapshot download; overloads server" - , "$feature{'snapshot'}{'default'} = [];" - ] - `describe` "gitweb configured" - -- Repos push on to github. - , Ssh.knownHost hosts "github.com" "joey" - -- I keep the website used for gitweb checked into git.. - , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing - , website "git.kitenet.net" - , website "git.joeyh.name" - , toProp $ Apache.modEnabled "cgi" - ] - where - website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True - [ " DocumentRoot /srv/web/git.kitenet.net/" - , " " - , " Options Indexes ExecCGI FollowSymlinks" - , " AllowOverride None" - , " AddHandler cgi-script .cgi" - , " DirectoryIndex index.cgi" - , " " - , "" - , " ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/" - , " " - , " SetHandler cgi-script" - , " Options ExecCGI" - , " " - ] - -type AnnexUUID = String - --- | A website, with files coming from a git-annex repository. -annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property -annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex") - [ Git.cloned "joey" origin dir Nothing - `onChange` setup - , postupdatehook `File.hasContent` - [ "#!/bin/sh" - , "exec git update-server-info" - ] `onChange` - (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) - , setupapache - ] - where - dir = "/srv/web/" ++ hn - postupdatehook = dir ".git/hooks/post-update" - setup = userScriptProperty "joey" setupscript - `requires` Ssh.keyImported SshRsa "joey" - `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey" - setupscript = - [ "cd " ++ shellEscape dir - , "git config annex.uuid " ++ shellEscape uuid - ] ++ map addremote remotes ++ - [ "git annex get" - ] - addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url - setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ - [ " ServerAlias www."++hn - , "" - , " DocumentRoot /srv/web/"++hn - , " " - , " Options FollowSymLinks" - , " AllowOverride None" - , " " - , " " - , " Options Indexes FollowSymLinks ExecCGI" - , " AllowOverride None" - , " AddHandler cgi-script .cgi" - , " DirectoryIndex index.html index.cgi" - , " Order allow,deny" - , " allow from all" - , " " - ] - -apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile -apachecfg hn withssl middle - | withssl = vhost False ++ vhost True - | otherwise = vhost False - where - vhost ssl = - [ "" - , " ServerAdmin grue@joeyh.name" - , " ServerName "++hn++":"++show port - ] - ++ mainhttpscert ssl - ++ middle ++ - [ "" - , " ErrorLog /var/log/apache2/error.log" - , " LogLevel warn" - , " CustomLog /var/log/apache2/access.log combined" - , " ServerSignature On" - , " " - , " " - , " Options Indexes MultiViews" - , " AllowOverride None" - , " Order allow,deny" - , " Allow from all" - , " " - , "" - ] - where - port = if ssl then 443 else 80 :: Int - -mainhttpscert :: Bool -> Apache.ConfigFile -mainhttpscert False = [] -mainhttpscert True = - [ " SSLEngine on" - , " SSLCertificateFile /etc/ssl/certs/web.pem" - , " SSLCertificateKeyFile /etc/ssl/private/web.pem" - , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" - ] - -gitAnnexDistributor :: Property -gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" - [ Apt.installed ["rsync"] - , File.hasPrivContent "/etc/rsyncd.conf" - , File.hasPrivContent "/etc/rsyncd.secrets" - , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" - `onChange` Service.running "rsync" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" - -- git-annex distribution signing key - , Gpg.keyImported "89C809CB" "joey" - ] - where - endpoint d = combineProperties ("endpoint " ++ d) - [ File.dirExists d - , File.ownerGroup d "joey" "joey" - ] - --- Twitter, you kill us. -twitRss :: Property -twitRss = combineProperties "twitter rss" - [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing - , check (not <$> doesFileExist (dir "twitRss")) $ - userScriptProperty "joey" - [ "cd " ++ dir - , "ghc --make twitRss" - ] - `requires` Apt.installed - [ "libghc-xml-dev" - , "libghc-feed-dev" - , "libghc-tagsoup-dev" - ] - , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" - , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" - ] - where - dir = "/srv/web/tmp.kitenet.net/twitrss" - crontime = "15 * * * *" - feed url desc = Cron.job desc crontime "joey" dir $ - "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") - -ircBouncer :: Property -ircBouncer = propertyList "IRC bouncer" - [ Apt.installed ["znc"] - , User.accountFor "znc" - , File.hasPrivContent conf - , File.ownerGroup conf "znc" "znc" - , Cron.job "znconboot" "@reboot" "znc" "~" "znc" - , Cron.job "zncrunning" "@hourly" "znc" "~" "znc || true" - ] - where - conf = "/home/znc/.znc/configs/znc.conf" diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs deleted file mode 100644 index a4f87678..00000000 --- a/Propellor/Property/Ssh.hs +++ /dev/null @@ -1,152 +0,0 @@ -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/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs deleted file mode 100644 index 68b56608..00000000 --- a/Propellor/Property/Sudo.hs +++ /dev/null @@ -1,32 +0,0 @@ -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/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs deleted file mode 100644 index 78e35c89..00000000 --- a/Propellor/Property/Tor.hs +++ /dev/null @@ -1,19 +0,0 @@ -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/Propellor/Property/User.hs b/Propellor/Property/User.hs deleted file mode 100644 index eef2a57e..00000000 --- a/Propellor/Property/User.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Propellor.Property.User where - -import System.Posix - -import Propellor - -data Eep = YesReallyDeleteHome - -accountFor :: UserName -> Property -accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" - [ "--disabled-password" - , "--gecos", "" - , user - ] - `describe` ("account for " ++ user) - --- | Removes user home directory!! Use with caution. -nuked :: UserName -> Eep -> Property -nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" - [ "-r" - , user - ] - `describe` ("nuked user " ++ user) - --- | Only ensures that the user has some password set. It may or may --- not be the password from the PrivData. -hasSomePassword :: UserName -> Property -hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $ - hasPassword user - -hasPassword :: UserName -> Property -hasPassword user = property (user ++ " has password") $ - withPrivData (Password user) $ \password -> makeChange $ - withHandle StdinHandle createProcessSuccess - (proc "chpasswd" []) $ \h -> do - hPutStrLn h $ user ++ ":" ++ password - hClose h - -lockedPassword :: UserName -> Property -lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" - [ "--lock" - , user - ] - `describe` ("locked " ++ user ++ " password") - -data PasswordStatus = NoPassword | LockedPassword | HasPassword - deriving (Eq) - -getPasswordStatus :: UserName -> IO PasswordStatus -getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user] - where - parse (_:"L":_) = LockedPassword - parse (_:"NP":_) = NoPassword - parse (_:"P":_) = HasPassword - parse _ = NoPassword - -isLockedPassword :: UserName -> IO Bool -isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user - -homedir :: UserName -> IO FilePath -homedir user = homeDirectory <$> getUserEntryForName user -- cgit v1.2.3