propellor 0.3.0 → 0.3.1

raw patch · 29 files changed

+981/−164 lines, 29 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +17/−0
• Propellor/Attr.hs +24/−0
• Propellor/Exception.hs +4/−2
• Propellor/Message.hs +2/−2
• Propellor/PrivData.hs +8/−1
• Propellor/Property.hs +33/−5
• Propellor/Property/Apache.hs +62/−0
• Propellor/Property/Apt.hs +24/−7
• Propellor/Property/Cron.hs +20/−5
• Propellor/Property/File.hs +36/−12
• Propellor/Property/Git.hs +41/−0
• Propellor/Property/Gpg.hs +41/−0
• Propellor/Property/Hostname.hs +3/−4
• Propellor/Property/Obnam.hs +96/−0
• Propellor/Property/OpenId.hs +6/−3
• Propellor/Property/Postfix.hs +25/−0
• Propellor/Property/Scheduled.hs +1/−1
• Propellor/Property/SiteSpecific/GitHome.hs +2/−4
• Propellor/Property/SiteSpecific/JoeySites.hs +191/−0
• Propellor/Property/Ssh.hs +98/−8
• Propellor/Property/User.hs +4/−4
• Propellor/Types.hs +11/−27
• Propellor/Types/Attr.hs +9/−1
• Propellor/Types/OS.hs +26/−0
• TODO +4/−3
• Utility/Scheduled.hs +78/−40
• config-joey.hs +92/−34
• debian/changelog +17/−0
• propellor.cabal +6/−1

@@ -1,3 +1,20 @@+propellor (0.3.1) unstable; urgency=medium++  * Merge scheduler bug fix from git-annex.+  * Support for provisioning hosts with ssh and gpg keys.+  * Obnam support.+  * Apache support.+  * Postfix satellite system support.+  * Properties can now be satisfied differently on different operating+    systems.+  * Standard apt configuration for stable now includes backports.+  * Cron jobs generated by propellor use flock(1) to avoid multiple+    instances running at a time.+  * Add support for SSH ed25519 keys.+    (Thanks, Franz Pletz.)++ -- Joey Hess <joeyh@debian.org>  Thu, 17 Apr 2014 20:07:33 -0400+ propellor (0.3.0) unstable; urgency=medium    * ipv6to4: Ensure interface is brought up automatically on boot.

@@ -8,6 +8,7 @@ import "mtl" Control.Monad.Reader import qualified Data.Set as S import qualified Data.Map as M+import Control.Applicative  pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty  pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)@@ -20,6 +21,13 @@ getHostName :: Propellor HostName getHostName = asks _hostname +os :: System -> AttrProperty+os system = pureAttrProperty ("Operating " ++ show system) $+	\d -> d { _os = Just system }++getOS :: Propellor (Maybe System)+getOS = asks _os+ cname :: Domain -> AttrProperty cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain) @@ -31,6 +39,13 @@ addCName :: HostName -> Attr -> Attr addCName domain d = d { _cnames = S.insert domain (_cnames d) } +sshPubKey :: String -> AttrProperty+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") @@ -45,3 +60,12 @@  findHost :: [Host] -> HostName -> Maybe Host findHost l hn = M.lookup hn (hostMap l)++-- | 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)

@@ -4,13 +4,15 @@  import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M import Control.Exception-import Control.Applicative  import Propellor.Types+import Propellor.Message  -- | Catches IO exceptions and returns FailedChange. catchPropellor :: Propellor Result -> Propellor Result-catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a+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

@@ -29,7 +29,7 @@ 	return r  warningMessage :: MonadIO m => String -> m ()-warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s+warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s  colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do@@ -43,7 +43,7 @@  errorMessage :: String -> IO a errorMessage s = do-	warningMessage s+	liftIO $ colorLine Vivid Red $ "** error: " ++ s 	error "Cannot continue!"  -- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1

@@ -8,6 +8,7 @@ import System.IO import System.Directory import Data.Maybe+import Data.List import Control.Monad import "mtl" Control.Monad.Reader @@ -22,14 +23,20 @@ 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 ++ "'"+			putStrLn $ "Fix this by running: propellor --set "++host'++" '" ++ show field ++ "'" 			return FailedChange  getPrivData :: PrivDataField -> IO (Maybe String)

@@ -10,8 +10,10 @@  import Propellor.Types import Propellor.Types.Attr+import Propellor.Attr import Propellor.Engine import Utility.Monad+import System.FilePath  makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange@@ -52,14 +54,19 @@ -- file to indicate whether it has run before. -- Use with caution. flagFile :: Property -> FilePath -> Property-flagFile property flagfile = Property (propertyDesc property) $-	go =<< liftIO (doesFileExist flagfile)+flagFile property = flagFile' property . return++flagFile' :: Property -> IO FilePath -> Property+flagFile' property getflagfile = Property (propertyDesc property) $ do+	flagfile <- liftIO getflagfile+	go flagfile =<< liftIO (doesFileExist flagfile)   where-	go True = return NoChange-	go False = do+	go _ True = return NoChange+	go flagfile False = do 		r <- ensureProperty property 		when (r == MadeChange) $ liftIO $ -			unlessM (doesFileExist flagfile) $+			unlessM (doesFileExist flagfile) $ do+				createDirectoryIfMissing True (takeDirectory flagfile) 				writeFile flagfile "" 		return r @@ -85,6 +92,26 @@ 	, 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 = Property (propertyDesc p) $ do+	r <- ensureProperty p+	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@@ -105,6 +132,7 @@ host hn = Host [] (\_ -> newAttr hn)  -- | Adds a property to a Host+-- -- Can add Properties, RevertableProperties, and AttrProperties (&) :: IsProp p => Host -> p -> Host (Host ps as) & p = Host (ps ++ [toProp p]) (getAttr p . as)

@@ -0,0 +1,62 @@+module Propellor.Property.Apache where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++type ConfigFile = [String]++siteEnabled :: HostName -> ConfigFile -> RevertableProperty+siteEnabled hn cf = RevertableProperty enable disable+  where+	enable = trivial $ cmdProperty "a2ensite" ["--quiet", hn]+		`describe` ("apache site enabled " ++ hn)+		`requires` siteAvailable hn cf+		`requires` installed+		`onChange` reloaded+	disable = trivial $ File.notPresent (siteCfg hn)+		`describe` ("apache site disabled " ++ hn)+		`onChange` cmdProperty "a2dissite" ["--quiet", hn]+		`requires` installed+		`onChange` reloaded++siteAvailable :: HostName -> ConfigFile -> Property+siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf)+	`describe` ("apache site available " ++ hn)+  where+	comment = "# deployed with propellor, do not modify"++modEnabled :: String -> RevertableProperty+modEnabled modname = RevertableProperty enable disable+  where+	enable = trivial $ cmdProperty "a2enmod" ["--quiet", modname]+		`describe` ("apache module enabled " ++ modname)+		`requires` installed+		`onChange` reloaded+	disable = trivial $ cmdProperty "a2dismod" ["--quiet", modname]+		`describe` ("apache module disabled " ++ modname)+		`requires` installed+		`onChange` reloaded++siteCfg :: HostName -> FilePath+siteCfg hn = "/etc/apache2/sites-available/" ++ hn++installed :: Property+installed = Apt.installed ["apache2"]++restarted :: Property+restarted = cmdProperty "service" ["apache2", "restart"]++reloaded :: Property+reloaded = Service.reloaded "apache2"++-- | Configure apache to use SNI to differentiate between+-- https hosts.+multiSSL :: Property+multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`+	[ "NameVirtualHost *:443"+	, "SSLStrictSNIVHostCheck off"+	]+	`describe` "apache SNI enabled"+	`onChange` reloaded

@@ -24,9 +24,12 @@ showSuite Experimental = "experimental" showSuite (DebianRelease r) = r -debLine :: DebianSuite -> Url -> [Section] -> Line+backportSuite :: String+backportSuite = showSuite stableRelease ++ "-backports"++debLine :: String -> Url -> [Section] -> Line debLine suite mirror sections = unwords $-	["deb", mirror, showSuite suite] ++ sections+	["deb", mirror, suite] ++ sections  srcLine :: Line -> Line srcLine l = case words l of@@ -37,9 +40,12 @@ stdSections = ["main", "contrib", "non-free"]  binandsrc :: String -> DebianSuite -> [Line]-binandsrc url suite = [l, srcLine l]+binandsrc url suite+	| isStable suite = [l, srcLine l, bl, srcLine bl]+	| otherwise = [l, srcLine l]   where-	l = debLine suite url stdSections+	l = debLine (showSuite suite) url stdSections+	bl = debLine backportSuite url stdSections  debCdn :: DebianSuite -> [Line] debCdn = binandsrc "http://cdn.debian.net/debian"@@ -50,7 +56,7 @@ -- | Only available for Stable and Testing securityUpdates :: DebianSuite -> [Line] securityUpdates suite-	| suite == Stable || suite == Testing =+	| isStable suite || suite == Testing = 		let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections 		in [l, srcLine l] 	| otherwise = []@@ -62,7 +68,7 @@ -- kernel.org. stdSourcesList :: DebianSuite -> Property stdSourcesList suite = setSourcesList-	(debCdn suite ++ kernelOrg suite ++ securityUpdates suite)+	(concatMap (\gen -> gen suite) [debCdn, kernelOrg, securityUpdates]) 	`describe` ("standard sources.list for " ++ show suite)  setSourcesList :: [Line] -> Property@@ -96,6 +102,17 @@   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"]@@ -183,7 +200,7 @@ 				forM_ vals $ \(tmpl, tmpltype, value) -> 					hPutStrLn h $ unwords [package, tmpl, tmpltype, value] 				hClose h-	reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]+	reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv  -- | Ensures that a service is installed and running. --

@@ -3,23 +3,38 @@ 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 specificed user, in a particular---directory. Note that the Desc must be unique, as it is used for the ---cron.d/ filename.+-- | 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. job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property-job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`+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" ++ "cd " ++ cddir ++ " && " ++ command+	, times ++ "\t" ++ user ++ "\t"+		++ "flock -n " ++ shellEscape cronjobfile+		++ " sh -c " ++ shellEscape cmdline 	] 	`requires` Apt.serviceInstalledRunning "cron" 	`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

@@ -1,8 +1,10 @@ module Propellor.Property.File where  import Propellor+import Utility.FileMode  import System.Posix.Files+import System.PosixCompat.Types  type Line = String @@ -12,19 +14,31 @@ 	(\_oldcontent -> newcontent) f  -- | Ensures a file has contents that comes from PrivData.--- Note: Does not do anything with the permissions of the file to prevent--- it from being seen.+--+-- The file's permissions are preserved if the file already existed.+-- Otherwise, they're set to 600. hasPrivContent :: FilePath -> Property-hasPrivContent f = Property ("privcontent " ++ f) $-	withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)+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 = fileProperty (f ++ " contains:" ++ l) go f+f `containsLine` l = f `containsLines` [l]++containsLines :: FilePath -> [Line] -> Property+f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f   where 	go ls-		| l `elem` ls = ls-		| otherwise = ls++[l]+		| 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@@ -38,7 +52,9 @@ 	makeChange $ nukeFile f  fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property-fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)+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@@ -46,13 +62,15 @@ 		if ls' == ls 			then noChange 			else makeChange $ viaTmp updatefile f (unlines ls')-	go False = makeChange $ writeFile f (unlines $ a [])+	go False = makeChange $ writer f (unlines $ a [])  	-- viaTmp makes the temp file mode 600.-	-- Replicate the original file mode before moving it into place.+	-- Replicate the original file's owner and mode. 	updatefile f' content = do-		writeFile f' content-		getFileStatus f >>= setFileMode f' . fileMode+		writer f' content+		s <- getFileStatus f+		setFileMode f' (fileMode s)+		setOwnerAndGroup f' (fileOwner s) (fileGroup s)  -- | Ensures a directory exists. dirExists :: FilePath -> Property@@ -68,3 +86,9 @@ 		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

@@ -4,6 +4,7 @@ import Propellor.Property.File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service+import Utility.SafeCommand  import Data.List @@ -46,3 +47,43 @@ 		, "--base-path=" ++ exportdir 		, exportdir 		]++installed :: Property+installed = Apt.installed ["git"]++type RepoUrl = String++type Branch = String++-- | Specified git repository is cloned to the specified directory.+--+-- If the firectory exists with some other content, it will be recursively+-- deleted.+--+-- A branch can be specified, to check out.+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property+cloned owner url dir mbranch = check originurl (Property desc checkout)+	`requires` installed+  where+	desc = "git cloned " ++ url ++ " to " ++ dir+	gitconfig = dir </> ".git/config"+	originurl = ifM (doesFileExist gitconfig)+		( do+			v <- catchDefaultIO Nothing $ headMaybe . lines <$>+				readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]+			return (v /= Just url)+		, return True+		)+	checkout = do+		liftIO $ do+			whenM (doesDirectoryExist dir) $+				removeDirectoryRecursive dir+			createDirectoryIfMissing True (takeDirectory dir)+		ensureProperty $ userScriptProperty owner $ catMaybes+			-- The </dev/null fixes an intermittent+			-- "fatal: read error: Bad file descriptor"+			-- when run across ssh with propellor --spin+			[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"+			, Just $ "cd " ++ shellEscape dir+			, ("git checkout " ++) <$> mbranch+			]

@@ -0,0 +1,41 @@+module Propellor.Property.Gpg where++import Propellor+import qualified Propellor.Property.Apt as Apt+import Utility.FileSystemEncoding++import System.PosixCompat++installed :: Property+installed = Apt.installed ["gnupg"]++-- | Sets up a user with a gpg key from the privdata.+--+-- Note that if a secret key is exported using gpg -a --export-secret-key,+-- the public key is also included. Or just a public key could be+-- exported, and this would set it up just as well.+--+-- Recommend only using this for low-value dedicated role keys.+-- No attempt has been made to scrub the key out of memory once it's used.+--+-- The GpgKeyId does not have to be a numeric id; it can just as easily+-- be a description of the key.+keyImported :: GpgKeyId -> UserName -> Property+keyImported keyid user = flagFile' (Property desc go) genflag+	`requires` installed+  where+	desc = user ++ " has gpg key " ++ show keyid+	genflag = do+		d <- dotDir user+		return $ d </> ".propellor-imported-keyid-" ++ keyid+	go = withPrivData (GpgKey keyid) $ \key -> makeChange $+		withHandle StdinHandle createProcessSuccess+			(proc "su" ["-c", "gpg --import", user]) $ \h -> do+				fileEncoding h+				hPutStr h key+				hClose h++dotDir :: UserName -> IO FilePath+dotDir user = do+	home <- homeDirectory <$> getUserEntryForName user+	return $ home </> ".gnupg"

@@ -4,11 +4,10 @@ import qualified Propellor.Property.File as File  -- | Ensures that the hostname is set to the HostAttr value.--- Configures both /etc/hostname and the current hostname.+-- Configures /etc/hostname and the current hostname. ----- When the hostname is a FQDN, also configures /etc/hosts,--- with an entry for 127.0.1.1, which is standard at least on Debian--- to set the FDQN (127.0.0.1 is localhost).+-- 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) 

@@ -0,0 +1,96 @@+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++installed :: Property+installed = Apt.installed ["obnam"]++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+			)

@@ -12,15 +12,18 @@ 	[ Apt.serviceInstalledRunning "apache2" 	, Apt.installed ["simpleid"] 		`onChange` Service.restarted "apache2"-	, File.fileProperty desc+	, File.fileProperty (desc ++ " configured") 		(map setbaseurl) "/etc/simpleid/config.inc" 	] ++ map identfile users   where-	identfile u = File.hasPrivContent $ concat-		[ "/var/lib/simpleid/identities/", u, ".identity" ] 	url = "http://"++baseurl++"/simpleid" 	desc = "openid provider " ++ url 	setbaseurl l 		| "SIMPLEID_BASE_URL" `isInfixOf` l =  			"define('SIMPLEID_BASE_URL', '"++url++"');" 		| otherwise = l+	+	-- the identitites directory controls access, so open up+	-- file mode+	identfile u = File.hasPrivContentExposed $+		concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ]

@@ -0,0 +1,25 @@+module Propellor.Property.Postfix where++import Propellor+import qualified Propellor.Property.Apt as Apt++installed :: Property+installed = Apt.serviceInstalledRunning "postfix"++-- | Configures postfix as a satellite system, which +-- relats all mail through a relay host, which defaults to smtp.domain. +--+-- The smarthost may refuse to relay mail on to other domains, without+-- futher coniguration/keys. But this should be enough to get cron job+-- mail flowing to a place where it will be seen.+satellite :: Property+satellite = setup `requires` installed+  where+	setup = trivial $ Property "postfix satellite system" $ do+		hn <- getHostName+		ensureProperty $ Apt.reConfigure "postfix"+			[ ("postfix/main_mailer_type", "select", "Satellite system")+			, ("postfix/root_address", "string", "root")+			, ("postfix/destinations", "string", " ")+			, ("postfix/mailname", "string", hn)+			]

@@ -61,7 +61,7 @@ readLastChecked :: IO (M.Map Desc LocalTime) readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go   where-	go = readish <$> readFile lastCheckedFile+	go = readish <$> readFileStrict lastCheckedFile  writeLastChecked :: M.Map Desc LocalTime -> IO () writeLastChecked = writeFile lastCheckedFile . show

@@ -11,8 +11,7 @@ 	Property ("githome " ++ user) (go =<< liftIO (homedir user)) 		`requires` Apt.installed ["git"]   where- 	go Nothing = noChange-	go (Just home) = do+	go home = do 		let tmpdir = home </> "githome" 		ensureProperty $ combineProperties "githome setup" 			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]@@ -32,5 +31,4 @@ hasGitDir :: UserName -> IO Bool hasGitDir user = go =<< homedir user   where-	go Nothing = return False-	go (Just home) = doesDirectoryExist (home </> ".git")+	go home = doesDirectoryExist (home </> ".git")

@@ -5,6 +5,16 @@  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  oldUseNetShellBox :: Property oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $@@ -21,3 +31,184 @@ 			, "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"++-- git.kitenet.net and git.joeyh.name+gitServer :: [Host] -> Property+gitServer hosts = propertyList "git.kitenet.net setup"+	[ Obnam.backup "/srv/git" "33 3 * * *"+		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"+		, "--encrypt-with=1B169BE1"+		, "--client-name=wren"+		] Obnam.OnlyClient+		`requires` Gpg.keyImported "1B169BE1" "root"+		`requires` Ssh.keyImported SshRsa "root"+		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"+		`requires` Ssh.authorizedKeys "family"+		`requires` User.accountFor "family"+	, Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"]+	, Apt.installedBackport ["git-annex"]+	, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"+	, toProp $ Git.daemonRunning "/srv/git"+	, "/etc/gitweb.conf" `File.containsLines`+		[ "$projectroot = '/srv/git';"+		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"+		, "# disable snapshot download; overloads server"+		, "$feature{'snapshot'}{'default'} = [];"+		]+		`describe` "gitweb configured"+	-- Repos push on to github.+	, Ssh.knownHost hosts "github.com" "joey"+	-- I keep the website used for gitweb checked into git..+	, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing+	, website "git.kitenet.net"+	, website "git.joeyh.name"+	, toProp $ Apache.modEnabled "cgi"+	]+  where+	website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True+		[ "  DocumentRoot /srv/web/git.kitenet.net/"+		, "  <Directory /srv/web/git.kitenet.net/>"+		, "    Options Indexes ExecCGI FollowSymlinks"+		, "    AllowOverride None"+		, "    AddHandler cgi-script .cgi"+		, "    DirectoryIndex index.cgi"+		, "  </Directory>"+		, ""+		, "  ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"+		, "  <Directory /usr/lib/cgi-bin>"+		, "    SetHandler cgi-script"+		, "    Options ExecCGI"+		, "  </Directory>"+		]++type AnnexUUID = String++-- | A website, with files coming from a git-annex repository.+annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property+annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")+	[ Git.cloned "joey" origin dir Nothing+		`onChange` setup+	, setupapache+	]+  where+	dir = "/srv/web/" ++ hn+	setup = userScriptProperty "joey" setupscript+		`requires` Ssh.keyImported SshRsa "joey"+		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"+	setupscript = +		[ "cd " ++ shellEscape dir+		, "git config annex.uuid " ++ shellEscape uuid+		] ++ map addremote remotes +++		[ "git annex get"+		]+	addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url+	setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ +		[ "  ServerAlias www."++hn+		, ""+		, "  DocumentRoot /srv/web/"++hn+		, "  <Directory /srv/web/"++hn++">"+		, "    Options FollowSymLinks"+		, "    AllowOverride None"+		, "  </Directory>"+		, "  <Directory /srv/web/"++hn++">"+		, "    Options Indexes FollowSymLinks ExecCGI"+		, "    AllowOverride None"+		, "    AddHandler cgi-script .cgi"+		, "    DirectoryIndex index.html index.cgi"+		, "    Order allow,deny"+		, "    allow from all"+		, "  </Directory>"+		]++apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile+apachecfg hn withssl middle+	| withssl = vhost False ++ vhost True+	| otherwise = vhost False+  where+	vhost ssl = +		[ "<VirtualHost *:"++show port++">"+		, "  ServerAdmin grue@joeyh.name"+		, "  ServerName "++hn++":"++show port+		]+		++ mainhttpscert ssl+		++ middle +++		[ ""+		, "  ErrorLog /var/log/apache2/error.log"+		, "  LogLevel warn"+		, "  CustomLog /var/log/apache2/access.log combined"+		, "  ServerSignature On"+		, "  "+		, "  <Directory \"/usr/share/apache2/icons\">"+		, "      Options Indexes MultiViews"+		, "      AllowOverride None"+		, "      Order allow,deny"+		, "      Allow from all"+		, "  </Directory>"+		, "</VirtualHost>"+		]+	  where+		port = if ssl then 443 else 80 :: Int++mainhttpscert :: Bool -> Apache.ConfigFile+mainhttpscert False = []+mainhttpscert True = +	[ "  SSLEngine on"+	, "  SSLCertificateFile /etc/ssl/certs/web.pem"+	, "  SSLCertificateKeyFile /etc/ssl/private/web.pem"+	, "  SSLCertificateChainFile /etc/ssl/certs/startssl.pem"+	]+		++annexRsyncServer :: Property+annexRsyncServer = combineProperties "rsync server for git-annex autobuilders"+	[ 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"+	]+  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")

@@ -4,14 +4,21 @@ 	passwordAuthentication, 	hasAuthorizedKeys, 	restartSshd,-	uniqueHostKeys+	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"@@ -35,12 +42,20 @@ 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 <=< homedir+hasAuthorizedKeys = go <=< dotFile "authorized_keys"   where-	go Nothing = return False-	go (Just home) = not . null <$> catchDefaultIO ""-		(readFile $ home </> ".ssh" </> "authorized_keys")+	go f = not . null <$> catchDefaultIO "" (readFile f)  restartSshd :: Property restartSshd = cmdProperty "service" ["ssh", "restart"]@@ -48,11 +63,11 @@ -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once.-uniqueHostKeys :: Property-uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"+randomHostKeys :: Property+randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" 	`onChange` restartSshd   where-	prop = Property "ssh unique host keys" $ do+	prop = Property "ssh random host keys" $ do 		void $ liftIO $ boolSystem "sh" 			[ Param "-c" 			, Param "rm -f /etc/ssh/ssh_host_*"@@ -60,3 +75,78 @@ 		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

@@ -7,7 +7,7 @@ data Eep = YesReallyDeleteHome  accountFor :: UserName -> Property-accountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"+accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" 	[ "--disabled-password" 	, "--gecos", "" 	, user@@ -16,7 +16,7 @@  -- | Removes user home directory!! Use with caution. nuked :: UserName -> Eep -> Property-nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"+nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" 	[ "-r" 	, user 	]@@ -57,5 +57,5 @@ isLockedPassword :: UserName -> IO Bool isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user -homedir :: UserName -> IO (Maybe FilePath)-homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user+homedir :: UserName -> IO FilePath+homedir user = homeDirectory <$> getUserEntryForName user

@@ -6,8 +6,6 @@ 	( Host(..) 	, Attr 	, HostName-	, UserName-	, GroupName 	, Propellor(..) 	, Property(..) 	, RevertableProperty(..)@@ -19,14 +17,12 @@ 	, requires 	, Desc 	, Result(..)-	, System(..)-	, Distribution(..)-	, DebianSuite(..)-	, Release-	, Architecture 	, ActionResult(..) 	, CmdLine(..) 	, PrivDataField(..)+	, GpgKeyId+	, SshKeyType(..)+	, module Propellor.Types.OS 	) where  import Data.Monoid@@ -36,12 +32,10 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO  import Propellor.Types.Attr+import Propellor.Types.OS  data Host = Host [Property] (Attr -> Attr) -type UserName = String-type GroupName = String- -- | Propellor's monad provides read-only access to attributes of the -- system. newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }@@ -117,22 +111,6 @@ 	mappend _ MadeChange = MadeChange 	mappend NoChange NoChange = NoChange --- | High level descritption of a operating system.-data System = System Distribution Architecture-	deriving (Show)--data Distribution-	= Debian DebianSuite-	| Ubuntu Release-	deriving (Show)--data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release-	deriving (Show, Eq)--type Release = String--type Architecture = String- -- | Results of actions, with color. class ActionResult a where 	getActionResult :: a -> (String, ColorIntensity, Color)@@ -162,9 +140,15 @@ -- It's fine to add new fields. data PrivDataField 	= DockerAuthentication-	| SshPrivKey UserName+	| 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)

@@ -1,11 +1,15 @@ module Propellor.Types.Attr where +import Propellor.Types.OS+ import qualified Data.Set as S  -- | The attributes of a host. For example, its hostname. data Attr = Attr 	{ _hostname :: HostName 	, _cnames :: S.Set Domain+	, _os :: Maybe System+	, _sshPubKey :: Maybe String  	, _dockerImage :: Maybe String 	, _dockerRunParams :: [HostName -> String]@@ -15,6 +19,8 @@ 	x == y = and 		[ _hostname x == _hostname y 		, _cnames x == _cnames y+		, _os x == _os y+		, _sshPubKey x == _sshPubKey y  		, _dockerImage x == _dockerImage y 		, let simpl v = map (\a -> a "") (_dockerRunParams v)@@ -25,12 +31,14 @@ 	show a = unlines 		[ "hostname " ++ _hostname a 		, "cnames " ++ show (_cnames a)+		, "OS " ++ show (_os a)+		, "sshPubKey " ++ show (_sshPubKey a) 		, "docker image " ++ show (_dockerImage a) 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) 		]  newAttr :: HostName -> Attr-newAttr hn = Attr hn S.empty Nothing []+newAttr hn = Attr hn S.empty Nothing Nothing Nothing []  type HostName = String type Domain = String

@@ -0,0 +1,26 @@+module Propellor.Types.OS where++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

@@ -2,9 +2,6 @@   run it once for the whole. For example, may want to restart apache,   but only once despite many config changes being made to satisfy   properties. onChange is a poor substitute.-* Currently only Debian and derivatives are supported by most Properties.-  This could be improved by making the Distribution of the system part-  of its HostAttr. * Display of docker container properties is a bit wonky. It always   says they are unchanged even when they changed and triggered a   reprovision.@@ -18,3 +15,7 @@ * There is no way for a property of a docker container to require   some property be met outside the container. For example, some servers   need ntp installed for a good date source.+* Attributes can only be set in the top level property list for a Host.+  If an attribute is set inside a propertyList, it won't propigate out.+  Fix this. Probably the fix involves combining AttrProperty into Property.+  Then propertyList can gather the attributes from its list.

@@ -1,6 +1,6 @@ {- scheduled activities  - - - Copyright 2013 Joey Hess <joey@kitenet.net>+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,6 +14,7 @@ 	MonthDay, 	YearDay, 	nextTime,+	calcNextTime, 	startTime, 	fromSchedule, 	fromScheduledTime,@@ -22,7 +23,8 @@ 	toRecurrance, 	toSchedule, 	parseSchedule,-	prop_schedule_roundtrips+	prop_schedule_roundtrips,+	prop_past_sane, ) where  import Utility.Data@@ -66,8 +68,8 @@ type Hour = Int type Minute = Int -{- Next time a Schedule should take effect. The NextTimeWindow is used- - when a Schedule is allowed to start at some point within the window. -}+-- | Next time a Schedule should take effect. The NextTimeWindow is used+-- when a Schedule is allowed to start at some point within the window. data NextTime 	= NextTimeExactly LocalTime 	| NextTimeWindow LocalTime LocalTime@@ -83,10 +85,10 @@ 	tz <- getTimeZone now 	return $ calcNextTime schedule lasttime $ utcToLocalTime tz now -{- Calculate the next time that fits a Schedule, based on the- - last time it occurred, and the current time. -}+-- | Calculate the next time that fits a Schedule, based on the+-- last time it occurred, and the current time. calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime-calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime+calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime 	| scheduledtime == AnyTime = do 		next <- findfromtoday True 		return $ case next of@@ -97,10 +99,10 @@   	findfromtoday anytime = findfrom recurrance afterday today 	  where 	  	today = localDay currenttime-		afterday = sameaslastday || toolatetoday+		afterday = sameaslastrun || toolatetoday 		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime-		sameaslastday = lastday == Just today-	lastday = localDay <$> lasttime+		sameaslastrun = lastrun == Just today+	lastrun = localDay <$> lasttime 	nexttime = case scheduledtime of 		AnyTime -> TimeOfDay 0 0 0 		SpecificTime h m -> TimeOfDay h m 0@@ -108,68 +110,84 @@ 	window startd endd = NextTimeWindow 		(LocalTime startd nexttime) 		(LocalTime endd (TimeOfDay 23 59 0))-	findfrom r afterday day = case r of+	findfrom r afterday candidate+		| ynum candidate > (ynum (localDay currenttime)) + 100 =+			-- avoid possible infinite recusion+			error $ "bug: calcNextTime did not find a time within 100 years to run " +++			show (schedule, lasttime, currenttime)+		| otherwise = findfromChecked r afterday candidate+	findfromChecked r afterday candidate = case r of 		Daily-			| afterday -> Just $ exactly $ addDays 1 day-			| otherwise -> Just $ exactly day+			| afterday -> Just $ exactly $ addDays 1 candidate+			| otherwise -> Just $ exactly candidate 		Weekly Nothing 			| afterday -> skip 1-			| otherwise -> case (wday <$> lastday, wday day) of-				(Nothing, _) -> Just $ window day (addDays 6 day)+			| otherwise -> case (wday <$> lastrun, wday candidate) of+				(Nothing, _) -> Just $ window candidate (addDays 6 candidate) 				(Just old, curr)-					| old == curr -> Just $ window day (addDays 6 day)+					| old == curr -> Just $ window candidate (addDays 6 candidate) 					| otherwise -> skip 1 		Monthly Nothing 			| afterday -> skip 1-			| maybe True (\old -> mnum day > mday old && mday day >= (mday old `mod` minmday)) lastday ->-				-- Window only covers current month,-				-- in case there is a Divisible requirement.-				Just $ window day (endOfMonth day)+			| maybe True (candidate `oneMonthPast`) lastrun ->+				Just $ window candidate (endOfMonth candidate) 			| otherwise -> skip 1 		Yearly Nothing 			| afterday -> skip 1-			| maybe True (\old -> ynum day > ynum old && yday day >= (yday old `mod` minyday)) lastday ->-				Just $ window day (endOfYear day)+			| maybe True (candidate `oneYearPast`) lastrun ->+				Just $ window candidate (endOfYear candidate) 			| otherwise -> skip 1 		Weekly (Just w) 			| w < 0 || w > maxwday -> Nothing-			| w == wday day -> if afterday-				then Just $ exactly $ addDays 7 day-				else Just $ exactly day+			| w == wday candidate -> if afterday+				then Just $ exactly $ addDays 7 candidate+				else Just $ exactly candidate 			| otherwise -> Just $ exactly $-				addDays (fromIntegral $ (w - wday day) `mod` 7) day+				addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate 		Monthly (Just m) 			| m < 0 || m > maxmday -> Nothing 			-- TODO can be done more efficiently than recursing-			| m == mday day -> if afterday+			| m == mday candidate -> if afterday 				then skip 1-				else Just $ exactly day+				else Just $ exactly candidate 			| otherwise -> skip 1 		Yearly (Just y) 			| y < 0 || y > maxyday -> Nothing-			| y == yday day -> if afterday+			| y == yday candidate -> if afterday 				then skip 365-				else Just $ exactly day+				else Just $ exactly candidate 			| otherwise -> skip 1 		Divisible n r'@Daily -> handlediv n r' yday (Just maxyday) 		Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum) 		Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum) 		Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing-		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday day+		Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate 	  where-	  	skip n = findfrom r False (addDays n day)+	  	skip n = findfrom r False (addDays n candidate) 	  	handlediv n r' getval mmax 			| n > 0 && maybe True (n <=) mmax =-				findfromwhere r' (divisible n . getval) afterday day+				findfromwhere r' (divisible n . getval) afterday candidate 			| otherwise = Nothing-	findfromwhere r p afterday day+	findfromwhere r p afterday candidate 		| maybe True (p . getday) next = next 		| otherwise = maybe Nothing (findfromwhere r p True . getday) next 	  where-		next = findfrom r afterday day+		next = findfrom r afterday candidate 		getday = localDay . startTime 	divisible n v = v `rem` n == 0 +-- Check if the new Day occurs one month or more past the old Day.+oneMonthPast :: Day -> Day -> Bool+new `oneMonthPast` old = fromGregorian y (m+1) d <= new+  where+	(y,m,d) = toGregorian old++-- Check if the new Day occurs one year or more past the old Day.+oneYearPast :: Day -> Day -> Bool+new `oneYearPast` old = fromGregorian (y+1) m d <= new+  where+	(y,m,d) = toGregorian old+ endOfMonth :: Day -> Day endOfMonth day = 	let (y,m,_d) = toGregorian day@@ -194,17 +212,13 @@ ynum :: Day -> Int ynum = fromIntegral . fst . toOrdinalDate -{- Calendar max and mins. -}+-- Calendar max values. maxyday :: Int maxyday = 366 -- with leap days-minyday :: Int-minyday = 365 maxwnum :: Int maxwnum = 53 -- some years have more than 52 maxmday :: Int maxmday = 31-minmday :: Int-minmday = 28 maxmnum :: Int maxmnum = 12 maxwday :: Int@@ -356,3 +370,27 @@  prop_schedule_roundtrips :: Schedule -> Bool prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s++prop_past_sane :: Bool+prop_past_sane = and+	[ all (checksout oneMonthPast) (mplus1 ++ yplus1)+	, all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))+	, all (checksout oneYearPast) yplus1+	, all (not . (checksout oneYearPast)) (map swap yplus1)+	]+  where+	mplus1 =   -- new date               old date, 1+ months before it+		[ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)+		, (fromGregorian 2014 01 15, fromGregorian 2013 02 15)+		, (fromGregorian 2014 02 15, fromGregorian 2013 01 15)+		, (fromGregorian 2014 03 01, fromGregorian 2013 01 15)+		, (fromGregorian 2014 03 01, fromGregorian 2013 12 15)+		, (fromGregorian 2015 01 01, fromGregorian 2010 01 01)+		]+	yplus1 =   -- new date               old date, 1+ years before it+		[ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)+		, (fromGregorian 2014 01 15, fromGregorian 2013 01 14)+		, (fromGregorian 2022 12 31, fromGregorian 2000 01 01)+		]+	checksout cmp (new, old) = new `cmp` old+	swap (a,b) = (b,a)

@@ -17,24 +17,33 @@ import qualified Propellor.Property.OpenId as OpenId import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Git as Git+import qualified Propellor.Property.Apache as Apache+import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites -hosts :: [Host]-hosts =++                      --     _         ______`|                          ,-.__ + {- Propellor          --  /   \___-=O`/|O`/__|                         (____.'+    Deployed -}         -- \          / | /    )             _.-"-._+                        --  `/-==__ _/__|/__=-|             (       \_+hosts :: [Host]        --   *             \ | |              '--------'+hosts =               --                  (o)  ` 	-- My laptop 	[ host "darkstar.kitenet.net" 		& Docker.configured 		& Apt.buildDep ["git-annex"] `period` Daily  	-- Nothing super-important lives here.-	, standardSystem "clam.kitenet.net" Unstable+	, standardSystem "clam.kitenet.net" Unstable "amd64" 		& cleanCloudAtCost 		& Apt.unattendedUpgrades 		& Network.ipv6to4 		& Tor.isBridge+		& Postfix.satellite 		& Docker.configured+ 		& cname "shell.olduse.net" 		& JoeySites.oldUseNetShellBox @@ -45,13 +54,18 @@ 		& cname "ancient.kitenet.net" 		& Docker.docked hosts "ancient-kitenet" +		-- I'd rather this were on diatom, but it needs unstable.+		& cname "kgb.kitenet.net"+		& JoeySites.kgbServer+ 		& Docker.garbageCollected `period` Daily 		& Apt.installed ["git-annex", "mtr", "screen"] 	 	-- Orca is the main git-annex build box.-	, standardSystem "orca.kitenet.net" Unstable+	, standardSystem "orca.kitenet.net" Unstable "amd64" 		& Hostname.sane 		& Apt.unattendedUpgrades+		& Postfix.satellite 		& Docker.configured 		& Docker.docked hosts "amd64-git-annex-builder" 		& Docker.docked hosts "i386-git-annex-builder"@@ -61,29 +75,53 @@ 		& Apt.buildDep ["git-annex"] `period` Daily 	 	-- Important stuff that needs not too much memory or CPU.-  	, standardSystem "diatom.kitenet.net" Stable+  	, standardSystem "diatom.kitenet.net" Stable "amd64" 		& Hostname.sane+		& Ssh.hostKey SshDsa+		& Ssh.hostKey SshRsa+		& Ssh.hostKey SshEcdsa 		& Apt.unattendedUpgrades 		& Apt.serviceInstalledRunning "ntp" 		& Dns.zones myDnsSecondary+		& Postfix.satellite+	 		& Apt.serviceInstalledRunning "apache2"-		& Apt.installed ["git", "git-annex", "rsync"]-		& Apt.buildDep ["git-annex"] `period` Daily-		& Git.daemonRunning "/srv/git"-		& File.ownerGroup "/srv/git" "joey" "joey"-		-- git repos restore (how?)-		-- family annex needs family members to have accounts,-		--     ssh host key etc.. finesse?-		--   (also should upgrade git-annex-shell for it..)-		-- kgb installation and setup-		-- ssh keys for branchable and github repo hooks-		-- gitweb-		-- downloads.kitenet.net setup (including ssh key to turtle)+		& File.hasPrivContent "/etc/ssl/certs/web.pem"+		& File.hasPrivContent "/etc/ssl/private/web.pem"+		& File.hasPrivContent "/etc/ssl/certs/startssl.pem"+		& Apache.modEnabled "ssl"+		& Apache.multiSSL+		& File.ownerGroup "/srv/web" "joey" "joey" -	---------------------------------------------------------------------	--  Docker Containers  ----------------------------------- \o/ ------	--------------------------------------------------------------------+		& cname "git.kitenet.net"+		& cname "git.joeyh.name"+		& JoeySites.gitServer hosts+	+		& cname "downloads.kitenet.net"+		& JoeySites.annexWebSite hosts "/srv/git/downloads.git"+			"downloads.kitenet.net"+			"840760dc-08f0-11e2-8c61-576b7e66acfd"+			[("turtle", "ssh://turtle.kitenet.net/~/lib/downloads/")]+		& JoeySites.annexRsyncServer +		& cname "tmp.kitenet.net"+		& JoeySites.annexWebSite hosts "/srv/git/joey/tmp.git"+			"tmp.kitenet.net"+			"26fd6e38-1226-11e2-a75f-ff007033bdba"+			[]+		& JoeySites.twitRss+		+		& Apt.installed ["ntop"]+++	    --'                        __|II|      ,.+	  ----                      __|II|II|__   (  \_,/\+	 ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-+	----------------------- |      [Docker]       / ----------------------+	----------------------- :                    / -----------------------+	------------------------ \____, o          ,' ------------------------+	------------------------- '--,___________,'  -------------------------+ 	-- Simple web server, publishing the outside host's /var/www 	, standardContainer "webserver" Stable "amd64" 		& Docker.publish "8080:80"@@ -96,18 +134,13 @@ 		& Docker.publish "8081:80" 		& OpenId.providerFor ["joey", "liw"] 			"openid.kitenet.net:8081"-	++	-- Exhibit: kite's 90's website. 	, standardContainer "ancient-kitenet" Stable "amd64" 		& Docker.publish "1994:80" 		& Apt.serviceInstalledRunning "apache2"-		& Apt.installed ["git"]-		& scriptProperty -			[ "cd /var/"-			, "rm -rf www"-			, "git clone git://git.kitenet.net/kitewiki www"-			, "cd www"-			, "git checkout remotes/origin/old-kitenet.net"-			] `flagFile` "/var/www/blastfromthepast.html"+		& Git.cloned "root" "git://git.kitenet.net/kitewiki" "/var/www"+			(Just "remotes/origin/old-kitenet.net") 	 	-- git-annex autobuilder containers 	, gitAnnexBuilder "amd64" 15@@ -126,7 +159,7 @@ 		& Docker.volumes_from "armel-git-annex-builder-companion" --		& GitAnnexBuilder.builder "armel" "15 * * * *" True 		& Apt.unattendedUpgrades-	]+	] ++ monsters  gitAnnexBuilder :: Architecture -> Int -> Host gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")@@ -135,8 +168,9 @@ 	& Apt.unattendedUpgrades  -- This is my standard system setup.-standardSystem :: HostName -> DebianSuite -> Host-standardSystem hn suite = host hn+standardSystem :: HostName -> DebianSuite -> Architecture -> Host+standardSystem hn suite arch = host hn+	& os (System (Debian suite) arch) 	& Apt.stdSourcesList suite `onChange` Apt.upgrade 	& Apt.installed ["etckeeper"] 	& Apt.installed ["ssh"]@@ -159,6 +193,7 @@ -- This is my standard container setup, featuring automatic upgrades. standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host standardContainer name suite arch = Docker.container name (image system)+	& os (System (Debian suite) arch) 	& Apt.stdSourcesList suite 	& Apt.unattendedUpgrades   where@@ -174,7 +209,7 @@ cleanCloudAtCost :: Property cleanCloudAtCost = propertyList "cloudatcost cleanup" 	[ Hostname.sane-	, Ssh.uniqueHostKeys+	, Ssh.randomHostKeys 	, "worked around grub/lvm boot bug #743126" ==> 		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" 		`onChange` cmdProperty "update-grub" []@@ -199,4 +234,27 @@ 	branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]  main :: IO ()-main = defaultMain hosts --, Docker.containerProperties container]+main = defaultMain hosts++++                          --                                o+                          --             ___                 o              o+                       {-----\          / o \              ___o            o+                       {      \    __   \   /   _        (X___>--         __o+  _____________________{ ______\___  \__/ | \__/ \____                  |X__>+ <                                  \___//|\\___/\     \____________   _+  \                                  ___/ | \___    # #             \ (-)+   \    O      O      O             #     |     \ #                  >=)+    \______________________________# #   /       #__________________/ (-}+++monsters :: [Host]    -- Systems I don't manage with propellor,+monsters =	      -- but do want to track their public keys.+	[ host "usw-s002.rsync.net"+		& sshPubKey "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ=="+	, host "turtle.kitenet.net"+		& sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAokMXQiX/NZjA1UbhMdgAscnS5dsmy+Q7bWrQ6tsTZ/o+6N/T5cbjoBHOdpypXJI3y/PiJTDJaQtXIhLa8gFg/EvxMnMz/KG9skADW1361JmfCc4BxicQIO2IOOe6eilPr+YsnOwiHwL0vpUnuty39cppuMWVD25GzxXlS6KQsLCvXLzxLLuNnGC43UAM0q4UwQxDtAZEK1dH2o3HMWhgMP2qEQupc24dbhpO3ecxh2C9678a3oGDuDuNf7mLp3s7ptj5qF3onitpJ82U5o7VajaHoygMaSRFeWxP2c13eM57j3bLdLwxVXFhePcKXARu1iuFTLS5uUf3hN6MkQcOGw=="+	, host "github.com" +		& sshPubKey "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ=="+	]

@@ -1,3 +1,20 @@+propellor (0.3.1) unstable; urgency=medium++  * Merge scheduler bug fix from git-annex.+  * Support for provisioning hosts with ssh and gpg keys.+  * Obnam support.+  * Apache support.+  * Postfix satellite system support.+  * Properties can now be satisfied differently on different operating+    systems.+  * Standard apt configuration for stable now includes backports.+  * Cron jobs generated by propellor use flock(1) to avoid multiple+    instances running at a time.+  * Add support for SSH ed25519 keys.+    (Thanks, Franz Pletz.)++ -- Joey Hess <joeyh@debian.org>  Thu, 17 Apr 2014 20:07:33 -0400+ propellor (0.3.0) unstable; urgency=medium    * ipv6to4: Ensure interface is brought up automatically on boot.

@@ -1,5 +1,5 @@ Name: propellor-Version: 0.3.0+Version: 0.3.1 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -68,6 +68,7 @@   Exposed-Modules:     Propellor     Propellor.Property+    Propellor.Property.Apache     Propellor.Property.Apt     Propellor.Property.Cmd     Propellor.Property.Hostname@@ -76,8 +77,11 @@     Propellor.Property.Docker     Propellor.Property.File     Propellor.Property.Git+    Propellor.Property.Gpg     Propellor.Property.Network+    Propellor.Property.Obnam     Propellor.Property.OpenId+    Propellor.Property.Postfix     Propellor.Property.Reboot     Propellor.Property.Scheduled     Propellor.Property.Service@@ -94,6 +98,7 @@     Propellor.Engine     Propellor.Exception     Propellor.Types+    Propellor.Types.OS   Other-Modules:     Propellor.Types.Attr     Propellor.CmdLine