diff options
Diffstat (limited to 'Propellor/Property')
-rw-r--r-- | Propellor/Property/Apt.hs | 193 | ||||
-rw-r--r-- | Propellor/Property/Cmd.hs | 48 | ||||
-rw-r--r-- | Propellor/Property/Cron.hs | 32 | ||||
-rw-r--r-- | Propellor/Property/Dns.hs | 63 | ||||
-rw-r--r-- | Propellor/Property/Docker.hs | 462 | ||||
-rw-r--r-- | Propellor/Property/Docker/Shim.hs | 61 | ||||
-rw-r--r-- | Propellor/Property/File.hs | 70 | ||||
-rw-r--r-- | Propellor/Property/Git.hs | 48 | ||||
-rw-r--r-- | Propellor/Property/Hostname.hs | 34 | ||||
-rw-r--r-- | Propellor/Property/Network.hs | 30 | ||||
-rw-r--r-- | Propellor/Property/OpenId.hs | 26 | ||||
-rw-r--r-- | Propellor/Property/Reboot.hs | 7 | ||||
-rw-r--r-- | Propellor/Property/Scheduled.hs | 67 | ||||
-rw-r--r-- | Propellor/Property/Service.hs | 31 | ||||
-rw-r--r-- | Propellor/Property/SiteSpecific/GitAnnexBuilder.hs | 57 | ||||
-rw-r--r-- | Propellor/Property/SiteSpecific/GitHome.hs | 36 | ||||
-rw-r--r-- | Propellor/Property/SiteSpecific/JoeySites.hs | 23 | ||||
-rw-r--r-- | Propellor/Property/Ssh.hs | 62 | ||||
-rw-r--r-- | Propellor/Property/Sudo.hs | 32 | ||||
-rw-r--r-- | Propellor/Property/Tor.hs | 19 | ||||
-rw-r--r-- | Propellor/Property/User.hs | 61 |
21 files changed, 1462 insertions, 0 deletions
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs new file mode 100644 index 00000000..4da13a2f --- /dev/null +++ b/Propellor/Property/Apt.hs @@ -0,0 +1,193 @@ +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 + +showSuite :: DebianSuite -> String +showSuite Stable = "stable" +showSuite Testing = "testing" +showSuite Unstable = "unstable" +showSuite Experimental = "experimental" +showSuite (DebianRelease r) = r + +debLine :: DebianSuite -> Url -> [Section] -> Line +debLine suite mirror sections = unwords $ + ["deb", mirror, showSuite 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 -> DebianSuite -> [Line] +binandsrc url suite = [l, srcLine l] + where + l = debLine suite url stdSections + +debCdn :: DebianSuite -> [Line] +debCdn = binandsrc "http://cdn.debian.net/debian" + +kernelOrg :: DebianSuite -> [Line] +kernelOrg = binandsrc "http://mirrors.kernel.org/debian" + +-- | Only available for Stable and Testing +securityUpdates :: DebianSuite -> [Line] +securityUpdates suite + | suite == Stable || 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 = setSourcesList + (debCdn suite ++ kernelOrg suite ++ securityUpdates suite) + `describe` ("standard sources.list for " ++ show suite) + +setSourcesList :: [Line] -> Property +setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update + +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 + +-- | 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 = Property (propertyDesc p) $ do + r <- ensureProperty p + 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" + 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" + +-- | 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] + +-- | 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] diff --git a/Propellor/Property/Cmd.hs b/Propellor/Property/Cmd.hs new file mode 100644 index 00000000..875c1f9a --- /dev/null +++ b/Propellor/Property/Cmd.hs @@ -0,0 +1,48 @@ +{-# 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 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 new file mode 100644 index 00000000..fa6019ea --- /dev/null +++ b/Propellor/Property/Cron.hs @@ -0,0 +1,32 @@ +module Propellor.Property.Cron where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +type CronTimes = String + +-- | Installs a cron job, run as a specificed user, in a particular +--directory. Note that the Desc must be unique, as it is used for the +--cron.d/ filename. +job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +job desc times user cddir command = ("/etc/cron.d/" ++ desc) `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" ++ "cd " ++ cddir ++ " && " ++ command + ] + `requires` Apt.serviceInstalledRunning "cron" + `describe` ("cronned " ++ desc) + +-- | 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) + `requires` Apt.installed ["util-linux", "moreutils"] + +-- | Installs a cron job to run propellor. +runPropellor :: CronTimes -> Property +runPropellor times = niceJob "propellor" times "root" localdir "chronic make" diff --git a/Propellor/Property/Dns.hs b/Propellor/Property/Dns.hs new file mode 100644 index 00000000..34e790d9 --- /dev/null +++ b/Propellor/Property/Dns.hs @@ -0,0 +1,63 @@ +module Propellor.Property.Dns where + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Service as Service + +namedconf :: FilePath +namedconf = "/etc/bind/named.conf.local" + +data Zone = Zone + { zdomain :: Domain + , ztype :: Type + , zfile :: FilePath + , zmasters :: [IPAddr] + , zconfiglines :: [String] + } + +zoneDesc :: Zone -> String +zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")" + +type IPAddr = String + +type Domain = String + +data Type = Master | Secondary + deriving (Show, Eq) + +secondary :: Domain -> [IPAddr] -> Zone +secondary domain masters = Zone + { zdomain = domain + , ztype = Secondary + , zfile = "db." ++ domain + , zmasters = masters + , zconfiglines = ["allow-transfer { }"] + } + +zoneStanza :: Zone -> [Line] +zoneStanza z = + [ "// automatically generated by propellor" + , "zone \"" ++ zdomain z ++ "\" {" + , cfgline "type" (if ztype z == Master then "master" else "slave") + , cfgline "file" ("\"" ++ zfile z ++ "\"") + ] ++ + (if null (zmasters z) then [] else mastersblock) ++ + (map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) ++ + [ "};" + , "" + ] + where + cfgline f v = "\t" ++ f ++ " " ++ v ++ ";" + mastersblock = + [ "\tmasters {" ] ++ + (map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) ++ + [ "\t};" ] + +-- | Rewrites the whole named.conf.local file to serve the specificed +-- zones. +zones :: [Zone] -> Property +zones zs = hasContent namedconf (concatMap zoneStanza zs) + `describe` ("dns server for zones: " ++ unwords (map zoneDesc zs)) + `requires` Apt.serviceInstalledRunning "bind9" + `onChange` Service.reloaded "bind9" diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs new file mode 100644 index 00000000..d2555ea5 --- /dev/null +++ b/Propellor/Property/Docker.hs @@ -0,0 +1,462 @@ +{-# 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 -> AttrProperty +dns = runProp "dns" + +-- | Set container host name. +hostname :: String -> AttrProperty +hostname = runProp "hostname" + +-- | Set name for container. (Normally done automatically.) +name :: String -> AttrProperty +name = runProp "name" + +-- | Publish a container's port to the host +-- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) +publish :: String -> AttrProperty +publish = runProp "publish" + +-- | Username or UID for container. +user :: String -> AttrProperty +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 -> AttrProperty +volume = runProp "volume" + +-- | Mount a volume from the specified container into the current +-- container. +volumes_from :: ContainerName -> AttrProperty +volumes_from cn = genProp "volumes-from" $ \hn -> + fromContainerId (ContainerId hn cn) + +-- | Work dir inside the container. +workdir :: String -> AttrProperty +workdir = runProp "workdir" + +-- | Memory limit for container. +--Format: <number><optional unit>, where unit = b, k, m or g +memory :: String -> AttrProperty +memory = runProp "memory" + +-- | Link with another container on the same host. +link :: ContainerName -> ContainerAlias -> AttrProperty +link linkwith alias = genProp "link" $ \hn -> + fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias + +-- | 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 + debug ["stdout: ", show s] + maybe noop putStrLn lastline + hFlush stdout + go (Just s) rest + StderrLine s -> do + debug ["stderr: ", show s] + maybe noop putStrLn lastline + hFlush stdout + hPutStrLn stderr s + hFlush stderr + go Nothing rest + Done -> ret lastline + go lastline [] = ret lastline + + ret lastline = return $ 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 -> AttrProperty +runProp field val = AttrProperty prop $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] } + where + param = field++"="++val + prop = Property (param) (return NoChange) + +genProp :: String -> (HostName -> RunParam) -> AttrProperty +genProp field mkval = AttrProperty prop $ \attr -> + attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] } + where + prop = Property field (return NoChange) + +-- | 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 new file mode 100644 index 00000000..c2f35d0c --- /dev/null +++ b/Propellor/Property/Docker/Shim.hs @@ -0,0 +1,61 @@ +-- | Support for running propellor, as built outside a docker container, +-- inside the container. +-- +-- Note: This is currently Debian specific, due to glibcLibs. + +module Propellor.Property.Docker.Shim (setup, cleanEnv, file) where + +import Propellor +import Utility.LinuxMkLibs +import Utility.SafeCommand +import Utility.Path +import Utility.FileMode + +import Data.List +import System.Posix.Files + +-- | Sets up a shimmed version of the program, in a directory, and +-- returns its path. +setup :: FilePath -> FilePath -> IO FilePath +setup propellorbin dest = do + createDirectoryIfMissing True dest + + libs <- parseLdd <$> readProcess "ldd" [propellorbin] + glibclibs <- glibcLibs + let libs' = nub $ libs ++ glibclibs + libdirs <- map (dest ++) . nub . catMaybes + <$> mapM (installLib installFile dest) libs' + + let linker = (dest ++) $ + fromMaybe (error "cannot find ld-linux linker") $ + headMaybe $ filter ("ld-linux" `isInfixOf`) libs' + let gconvdir = (dest ++) $ parentDir $ + fromMaybe (error "cannot find gconv directory") $ + headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs + let linkerparams = ["--library-path", intercalate ":" libdirs ] + let shim = file propellorbin dest + writeFile shim $ unlines + [ "#!/bin/sh" + , "GCONV_PATH=" ++ shellEscape gconvdir + , "export GCONV_PATH" + , "exec " ++ unwords (map shellEscape $ linker : linkerparams) ++ + " " ++ shellEscape propellorbin ++ " \"$@\"" + ] + modifyFileMode shim (addModes executeModes) + return shim + +cleanEnv :: IO () +cleanEnv = void $ unsetEnv "GCONV_PATH" + +file :: FilePath -> FilePath -> FilePath +file propellorbin dest = dest </> takeFileName propellorbin + +installFile :: FilePath -> FilePath -> IO () +installFile top f = do + createDirectoryIfMissing True destdir + nukeFile dest + createLink f dest `catchIO` (const copy) + where + copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] + destdir = inTop top $ parentDir f + dest = inTop top f diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs new file mode 100644 index 00000000..10dee75e --- /dev/null +++ b/Propellor/Property/File.hs @@ -0,0 +1,70 @@ +module Propellor.Property.File where + +import Propellor + +import System.Posix.Files + +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. +-- Note: Does not do anything with the permissions of the file to prevent +-- it from being seen. +hasPrivContent :: FilePath -> Property +hasPrivContent f = Property ("privcontent " ++ f) $ + withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v) + +-- | Ensures that a line is present in a file, adding it to the end if not. +containsLine :: FilePath -> Line -> Property +f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f + where + go ls + | l `elem` ls = 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 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 $ writeFile f (unlines $ a []) + + -- viaTmp makes the temp file mode 600. + -- Replicate the original file mode before moving it into place. + updatefile f' content = do + writeFile f' content + getFileStatus f >>= setFileMode f' . fileMode + +-- | 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 diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs new file mode 100644 index 00000000..c0494160 --- /dev/null +++ b/Propellor/Property/Git.hs @@ -0,0 +1,48 @@ +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 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 + ] diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs new file mode 100644 index 00000000..03613ac9 --- /dev/null +++ b/Propellor/Property/Hostname.hs @@ -0,0 +1,34 @@ +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 both /etc/hostname and the current hostname. +-- +-- When the hostname is 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 new file mode 100644 index 00000000..6009778a --- /dev/null +++ b/Propellor/Property/Network.hs @@ -0,0 +1,30 @@ +module Propellor.Property.Network where + +import Propellor +import Propellor.Property.File + +interfaces :: FilePath +interfaces = "/etc/network/interfaces" + +-- | 6to4 ipv6 connection, should work anywhere +ipv6to4 :: Property +ipv6to4 = fileProperty "ipv6to4" go interfaces + `onChange` ifUp "sit0" + where + go ls + | all (`elem` ls) stanza = ls + | otherwise = ls ++ stanza + stanza = + [ "# Automatically added by propeller" + , "iface sit0 inet6 static" + , "\taddress 2002:5044:5531::1" + , "\tnetmask 64" + , "\tgateway ::192.88.99.1" + , "auto sit0" + , "# End automatically added by propeller" + ] + +type Interface = String + +ifUp :: Interface -> Property +ifUp iface = cmdProperty "ifup" [iface] diff --git a/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs new file mode 100644 index 00000000..c397bdb8 --- /dev/null +++ b/Propellor/Property/OpenId.hs @@ -0,0 +1,26 @@ +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 + (map setbaseurl) "/etc/simpleid/config.inc" + ] ++ map identfile users + where + identfile u = File.hasPrivContent $ concat + [ "/var/lib/simpleid/identities/", u, ".identity" ] + url = "http://"++baseurl++"/simpleid" + desc = "openid provider " ++ url + setbaseurl l + | "SIMPLEID_BASE_URL" `isInfixOf` l = + "define('SIMPLEID_BASE_URL', '"++url++"');" + | otherwise = l diff --git a/Propellor/Property/Reboot.hs b/Propellor/Property/Reboot.hs new file mode 100644 index 00000000..25e53159 --- /dev/null +++ b/Propellor/Property/Reboot.hs @@ -0,0 +1,7 @@ +module Propellor.Property.Reboot where + +import Propellor + +now :: Property +now = cmdProperty "reboot" [] + `describe` "reboot now" diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs new file mode 100644 index 00000000..8341765e --- /dev/null +++ b/Propellor/Property/Scheduled.hs @@ -0,0 +1,67 @@ +module Propellor.Property.Scheduled + ( period + , periodParse + , Recurrance(..) + , WeekDay + , MonthDay + , YearDay + ) where + +import Propellor +import Utility.Scheduled + +import Data.Time.Clock +import Data.Time.LocalTime +import qualified Data.Map as M + +-- | Makes a Property only be checked every so often. +-- +-- This uses the description of the Property to keep track of when it was +-- last run. +period :: Property -> Recurrance -> Property +period prop recurrance = Property desc $ do + lasttime <- liftIO $ getLastChecked (propertyDesc prop) + nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime + t <- liftIO localNow + if Just t >= nexttime + then do + r <- ensureProperty prop + 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 <$> readFile lastCheckedFile + +writeLastChecked :: M.Map Desc LocalTime -> IO () +writeLastChecked = writeFile lastCheckedFile . show diff --git a/Propellor/Property/Service.hs b/Propellor/Property/Service.hs new file mode 100644 index 00000000..c6498e57 --- /dev/null +++ b/Propellor/Property/Service.hs @@ -0,0 +1,31 @@ +module Propellor.Property.Service where + +import Propellor +import Utility.SafeCommand + +type ServiceName = String + +-- | Ensures that a service is running. Does not ensure that +-- any package providing that service is installed. See +-- Apt.serviceInstalledRunning +-- +-- Note that due to the general poor state of init scripts, the best +-- we can do is try to start the service, and if it fails, assume +-- this means it's already running. +running :: ServiceName -> Property +running svc = Property ("running " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"] + return NoChange + +restarted :: ServiceName -> Property +restarted svc = Property ("restarted " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"] + return NoChange + +reloaded :: ServiceName -> Property +reloaded svc = Property ("reloaded " ++ svc) $ do + void $ ensureProperty $ + scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"] + return NoChange diff --git a/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs new file mode 100644 index 00000000..204a9ca7 --- /dev/null +++ b/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -0,0 +1,57 @@ +module Propellor.Property.SiteSpecific.GitAnnexBuilder where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.User as User +import qualified Propellor.Property.Cron as Cron +import Propellor.Property.Cron (CronTimes) + +builduser :: UserName +builduser = "builder" + +homedir :: FilePath +homedir = "/home/builder" + +gitbuilderdir :: FilePath +gitbuilderdir = homedir </> "gitbuilder" + +builddir :: FilePath +builddir = gitbuilderdir </> "build" + +builder :: Architecture -> CronTimes -> Bool -> Property +builder arch crontimes rsyncupload = combineProperties "gitannexbuilder" + [ Apt.stdSourcesList Unstable + , Apt.buildDep ["git-annex"] + , Apt.installed ["git", "rsync", "moreutils", "ca-certificates", + "liblockfile-simple-perl", "cabal-install", "vim", "less"] + , Apt.serviceInstalledRunning "cron" + , User.accountFor builduser + , check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser + [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir + , "cd " ++ gitbuilderdir + , "git checkout " ++ arch + ] + `describe` "gitbuilder setup" + , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + [ "git clone git://git-annex.branchable.com/ " ++ builddir + ] + , "git-annex source build deps installed" ==> Apt.buildDepIn builddir + , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir "git pull ; ./autobuild" + -- The builduser account does not have a password set, + -- instead use the password privdata to hold the rsync server + -- password used to upload the built image. + , Property "rsync password" $ do + let f = homedir </> "rsyncpassword" + if rsyncupload + then withPrivData (Password builduser) $ \p -> do + oldp <- liftIO $ catchDefaultIO "" $ + readFileStrict f + if p /= oldp + then makeChange $ writeFile f p + else noChange + else do + ifM (liftIO $ doesFileExist f) + ( noChange + , makeChange $ writeFile f "no password configured" + ) + ] diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs new file mode 100644 index 00000000..1ba56b94 --- /dev/null +++ b/Propellor/Property/SiteSpecific/GitHome.hs @@ -0,0 +1,36 @@ +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 Nothing = noChange + go (Just 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 Nothing = return False + go (Just home) = doesDirectoryExist (home </> ".git") diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs new file mode 100644 index 00000000..46373170 --- /dev/null +++ b/Propellor/Property/SiteSpecific/JoeySites.hs @@ -0,0 +1,23 @@ +-- | 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 + +oldUseNetShellBox :: Property +oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $ + propertyList ("olduse.net shellbox") + [ 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 ../oldusenet*.deb || true" + , "apt-get -fy install" -- dependencies + , "rm -rf /root/tmp/oldusenet" + ] `describe` "olduse.net built" + ] diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs new file mode 100644 index 00000000..59845f8f --- /dev/null +++ b/Propellor/Property/Ssh.hs @@ -0,0 +1,62 @@ +module Propellor.Property.Ssh ( + setSshdConfig, + permitRootLogin, + passwordAuthentication, + hasAuthorizedKeys, + restartSshd, + uniqueHostKeys +) where + +import Propellor +import qualified Propellor.Property.File as File +import Propellor.Property.User +import Utility.SafeCommand + +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" + +hasAuthorizedKeys :: UserName -> IO Bool +hasAuthorizedKeys = go <=< homedir + where + go Nothing = return False + go (Just home) = not . null <$> catchDefaultIO "" + (readFile $ home </> ".ssh" </> "authorized_keys") + +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. +uniqueHostKeys :: Property +uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" + `onChange` restartSshd + where + prop = Property "ssh unique 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"] diff --git a/Propellor/Property/Sudo.hs b/Propellor/Property/Sudo.hs new file mode 100644 index 00000000..66ceb580 --- /dev/null +++ b/Propellor/Property/Sudo.hs @@ -0,0 +1,32 @@ +module Propellor.Property.Sudo where + +import Data.List + +import Propellor +import Propellor.Property.File +import qualified Propellor.Property.Apt as Apt +import Propellor.Property.User + +-- | Allows a user to sudo. If the user has a password, sudo is configured +-- to require it. If not, NOPASSWORD is enabled for the user. +enabledFor :: UserName -> Property +enabledFor user = Property desc go `requires` Apt.installed ["sudo"] + where + go = do + locked <- liftIO $ isLockedPassword user + ensureProperty $ + fileProperty desc + (modify locked . filter (wanted locked)) + "/etc/sudoers" + desc = user ++ " is sudoer" + sudobaseline = user ++ " ALL=(ALL:ALL)" + sudoline True = sudobaseline ++ " NOPASSWD:ALL" + sudoline False = sudobaseline ++ " ALL" + wanted locked l + -- TOOD: Full sudoers file format parse.. + | not (sudobaseline `isPrefixOf` l) = True + | "NOPASSWD" `isInfixOf` l = locked + | otherwise = True + modify locked ls + | sudoline locked `elem` ls = ls + | otherwise = ls ++ [sudoline locked] diff --git a/Propellor/Property/Tor.hs b/Propellor/Property/Tor.hs new file mode 100644 index 00000000..78e35c89 --- /dev/null +++ b/Propellor/Property/Tor.hs @@ -0,0 +1,19 @@ +module Propellor.Property.Tor where + +import Propellor +import qualified Propellor.Property.File as File +import qualified Propellor.Property.Apt as Apt + +isBridge :: Property +isBridge = setup `requires` Apt.installed ["tor"] + `describe` "tor bridge" + where + setup = "/etc/tor/torrc" `File.hasContent` + [ "SocksPort 0" + , "ORPort 443" + , "BridgeRelay 1" + , "Exitpolicy reject *:*" + ] `onChange` restartTor + +restartTor :: Property +restartTor = cmdProperty "service" ["tor", "restart"] diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs new file mode 100644 index 00000000..9d948834 --- /dev/null +++ b/Propellor/Property/User.hs @@ -0,0 +1,61 @@ +module Propellor.Property.User where + +import System.Posix + +import Propellor + +data Eep = YesReallyDeleteHome + +accountFor :: UserName -> Property +accountFor user = check (isNothing <$> 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 <$> 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 (Maybe FilePath) +homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user |