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