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