propellor 0.2.3 → 0.3.0

raw patch · 39 files changed

+1421/−428 lines, 39 filesdep +MonadCatchIO-transformersdep +QuickCheckdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadCatchIO-transformers, QuickCheck, mtl, time

API changes (from Hackage documentation)

Files

• CHANGELOG +15/−0
• Makefile +2/−1
• Propellor.hs +19/−10
• Propellor/Attr.hs +47/−0
• Propellor/CmdLine.hs +49/−33
• Propellor/Engine.hs +15/−8
• Propellor/Exception.hs +16/−0
• Propellor/Message.hs +15/−10
• Propellor/PrivData.hs +11/−4
• Propellor/Property.hs +44/−19
• Propellor/Property/Apt.hs +25/−5
• Propellor/Property/Cmd.hs +4/−15
• Propellor/Property/Cron.hs +1/−2
• Propellor/Property/Dns.hs +63/−0
• Propellor/Property/Docker.hs +107/−121
• Propellor/Property/File.hs +19/−2
• Propellor/Property/Git.hs +48/−0
• Propellor/Property/Hostname.hs +13/−10
• Propellor/Property/Network.hs +1/−0
• Propellor/Property/OpenId.hs +26/−0
• Propellor/Property/Scheduled.hs +67/−0
• Propellor/Property/Service.hs +31/−0
• Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +4/−3
• Propellor/Property/SiteSpecific/GitHome.hs +3/−3
• Propellor/Property/SiteSpecific/JoeySites.hs +2/−2
• Propellor/Property/Ssh.hs +1/−1
• Propellor/Property/Sudo.hs +1/−1
• Propellor/SimpleSh.hs +1/−1
• Propellor/Types.hs +69/−4
• Propellor/Types/Attr.hs +36/−0
• TODO +11/−7
• Utility/QuickCheck.hs +52/−0
• Utility/Scheduled.hs +358/−0
• config-joey.hs +155/−96
• config-simple.hs +27/−33
• config.hs +27/−33
• debian/changelog +15/−0
• debian/control +4/−0
• propellor.cabal +17/−4

@@ -1,3 +1,18 @@+propellor (0.3.0) unstable; urgency=medium++  * ipv6to4: Ensure interface is brought up automatically on boot.+  * Enabling unattended upgrades now ensures that cron is installed and+    running to perform them.+  * Properties can be scheduled to only be checked after a given time period.+  * Fix bootstrapping of dependencies.+  * Fix compilation on Debian stable.+  * Include security updates in sources.list for stable and testing.+  * Use ssh connection caching, especially when bootstrapping.+  * Properties now run in a Propellor monad, which provides access to+    attributes of the host.++ -- Joey Hess <joeyh@debian.org>  Fri, 11 Apr 2014 01:19:05 -0400+ propellor (0.2.3) unstable; urgency=medium    * docker: Fix laziness bug that caused running containers to be

@@ -10,7 +10,8 @@ 	ln -sf dist/build/config/config propellor  deps:-	@if [ $$(whoami) = root ]; then apt-get -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-async-dev; fi || true+	@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install gnupg ghc cabal-install libghc-missingh-dev libghc-ansi-terminal-dev libghc-ifelse-dev libghc-unix-compat-dev libghc-hslogger-dev libghc-network-dev libghc-quickcheck2-dev libghc-mtl-dev libghc-monadcatchio-transformers-dev; fi || true+	@if [ $$(whoami) = root ]; then apt-get --no-upgrade --no-install-recommends -y install libghc-async-dev || cabal update; cabal install async; fi || true  dist/setup-config: propellor.cabal 	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi

@@ -1,7 +1,10 @@+{-# LANGUAGE PackageImports #-}+ -- | Pulls in lots of useful modules for building and using Properties. -- --- Propellor enures that the system it's run in satisfies a list of--- properties, taking action as necessary when a property is not yet met.+-- When propellor runs on a Host, it ensures that its list of Properties+-- is satisfied, taking action as necessary when a Property is not+-- currently satisfied. -- -- A simple propellor program example: --@@ -11,15 +14,16 @@ -- > import qualified Propellor.Property.Apt as Apt -- >  -- > main :: IO ()--- > main = defaultMain getProperties+-- > main = defaultMain hosts -- > --- > getProperties :: HostName -> Maybe [Property]--- > getProperties "example.com" = Just--- >    [ Apt.installed ["mydaemon"]--- >    , "/etc/mydaemon.conf" `File.containsLine` "secure=1"--- >        `onChange` cmdProperty "service" ["mydaemon", "restart"]--- >    ]--- > getProperties _ = Nothing+-- > hosts :: [Host]+-- > hosts =+-- >   [ host "example.com"+-- >     & Apt.installed ["mydaemon"]+-- >     & "/etc/mydaemon.conf" `File.containsLine` "secure=1"+-- >       `onChange` cmdProperty "service" ["mydaemon", "restart"]+-- >     ! Apt.installed ["unwantedpackage"]+-- >   ] -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor:@@ -29,8 +33,10 @@ 	  module Propellor.Types 	, module Propellor.Property 	, module Propellor.Property.Cmd+	, module Propellor.Attr 	, module Propellor.PrivData 	, module Propellor.Engine+	, module Propellor.Exception 	, module Propellor.Message 	, localdir @@ -43,6 +49,8 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Message+import Propellor.Exception+import Propellor.Attr  import Utility.PartialPrelude as X import Utility.Process as X@@ -62,6 +70,7 @@ import Control.Monad as X import Data.Monoid as X import Control.Monad.IfElse as X+import "mtl" Control.Monad.Reader as X  -- | This is where propellor installs itself when deploying a host. localdir :: FilePath

@@ -0,0 +1,47 @@+{-# 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++pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty +pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)+	(return NoChange)++hostname :: HostName -> AttrProperty+hostname name = pureAttrProperty ("hostname " ++ name) $+	\d -> d { _hostname = name }++getHostName :: Propellor HostName+getHostName = asks _hostname++cname :: Domain -> AttrProperty+cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)++cnameFor :: IsProp p => Domain -> (Domain -> p) -> AttrProperty+cnameFor domain mkp =+	let p = mkp domain+	in AttrProperty p (addCName domain)++addCName :: HostName -> Attr -> Attr+addCName domain d = d { _cnames = S.insert domain (_cnames d) }++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 ++findHost :: [Host] -> HostName -> Maybe Host+findHost l hn = M.lookup hn (hostMap l)

@@ -16,6 +16,7 @@ import qualified Propellor.Property.Docker.Shim as DockerShim import Utility.FileMode import Utility.SafeCommand+import Utility.UserInfo  usage :: IO a usage = do@@ -54,8 +55,8 @@ 			else return $ Run s 	go _ = usage -defaultMain :: [HostName -> Maybe [Property]] -> IO ()-defaultMain getprops = do+defaultMain :: [Host] -> IO ()+defaultMain hostlist = do 	DockerShim.cleanEnv 	checkDebugMode 	cmdline <- processCmdLine@@ -63,23 +64,26 @@ 	go True cmdline   where 	go _ (Continue cmdline) = go False cmdline-	go _ (Set host field) = setPrivData host field+	go _ (Set hn field) = setPrivData hn field 	go _ (AddKey keyid) = addKey keyid-	go _ (Chain host) = withprops host $ \ps -> do-		r <- ensureProperties' ps+	go _ (Chain hn) = withprops hn $ \attr ps -> do+		r <- runPropellor attr $ ensureProperties ps 		putStrLn $ "\n" ++ show r-	go _ (Docker host) = Docker.chain host+	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 host) = withprops host $ const $ spin host-	go False (Run host) = ifM ((==) 0 <$> getRealUserID)-		( onlyProcess $ withprops host ensureProperties-		, go True (Spin host)+	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 host) = onlyProcess $ withprops host $ boot+	go False (Boot hn) = onlyProcess $ withprops hn boot -	withprops host a = maybe (unknownhost host) a $-		headMaybe $ catMaybes $ map (\get -> get host) getprops+	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)@@ -95,7 +99,7 @@  unknownhost :: HostName -> IO a unknownhost h = errorMessage $ unlines-	[ "Unknown host: " ++ h+	[ "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)" 	]@@ -163,15 +167,16 @@ getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]  spin :: HostName -> IO ()-spin host = do+spin hn = do 	url <- getUrl 	void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] 	void $ boolSystem "git" [Param "push"]-	go url =<< gpgDecrypt (privDataFile host)+	cacheparams <- toCommand <$> sshCachingParams hn+	go cacheparams url =<< gpgDecrypt (privDataFile hn)   where-	go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do+	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do 		let finish = do-			senddata toh (privDataFile host) privDataMarker privdata+			senddata toh (privDataFile hn) privDataMarker privdata 			hClose toh 			 			-- Display remaining output.@@ -184,21 +189,21 @@ 			NeedGitClone -> do 				hClose toh 				hClose fromh-				sendGitClone host url-				go url privdata+				sendGitClone hn url+				go cacheparams url privdata 	-	user = "root@"++host+	user = "root@"++hn  	bootstrapcmd = shellWrap $ intercalate " ; " 		[ "if [ ! -d " ++ localdir ++ " ]" 		, "then " ++ intercalate " && "-			[ "apt-get -y install git"+			[ "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 build; fi"-			, "./propellor --boot " ++ host+			, "if ! test -x ./propellor; then make deps build; fi"+			, "./propellor --boot " ++ hn 			] 		, "fi" 		]@@ -214,19 +219,18 @@ 	 	showremote s = putStrLn s 	senddata toh f marker s = void $-		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ host) $ do+		actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do 			sendMarked toh marker s 			return True  sendGitClone :: HostName -> String -> IO ()-sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $ do+sendGitClone hn url = void $ actionMessage ("Pushing git repository to " ++ hn) $ do 	branch <- getCurrentBranch+	cacheparams <- sshCachingParams hn 	withTmpFile "propellor.git" $ \tmp _ -> allM id-		-- TODO: ssh connection caching, or better push method-		-- with less connections. 		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]-		, boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]-		, boolSystem "ssh" [Param ("root@"++host), Param $ unpackcmd branch]+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] 		]   where 	remotebundle = "/usr/local/propellor.git"@@ -274,15 +278,15 @@ 	len = length marker 	matches = filter (marker `isPrefixOf`) $ lines s -boot :: [Property] -> IO ()-boot ps = do+boot :: Attr -> [Property] -> IO ()+boot attr ps = do 	sendMarked stdout statusMarker $ show Ready 	reply <- hGetContentsStrict stdin  	makePrivDataDir 	maybe noop (writeFileProtected privDataLocal) $ 		fromMarked privDataMarker reply-	ensureProperties ps+	mainProperties attr ps  addKey :: String -> IO () addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]@@ -341,3 +345,15 @@ 			updateGlobalLogger rootLoggerName $  				setLevel DEBUG .  setHandlers [f] 	go _ = noop++-- Parameters can be passed to both ssh and scp.+sshCachingParams :: HostName -> IO [CommandParam]+sshCachingParams hn = do+	home <- myHomeDir+	let cachedir = home </> ".ssh" </> "propellor"+	createDirectoryIfMissing False cachedir+	let socketfile = cachedir </> hn ++ ".sock"+	return+		[ Param "-o", Param ("ControlPath=" ++ socketfile)+		, Params "-o ControlMaster=auto -o ControlPersist=yes"+		]

@@ -1,30 +1,37 @@+{-# LANGUAGE PackageImports #-}+ module Propellor.Engine where  import System.Exit import System.IO import Data.Monoid import System.Console.ANSI+import "mtl" Control.Monad.Reader  import Propellor.Types import Propellor.Message-import Utility.Exception+import Propellor.Exception -ensureProperty :: Property -> IO Result-ensureProperty = catchDefaultIO FailedChange . propertySatisfy+runPropellor :: Attr -> Propellor a -> IO a+runPropellor attr a = runReaderT (runWithAttr a) attr -ensureProperties :: [Property] -> IO ()-ensureProperties ps = do-	r <- ensureProperties' [Property "overall" $ ensureProperties' ps]+mainProperties :: Attr -> [Property] -> IO ()+mainProperties attr ps = do+	r <- runPropellor attr $+		ensureProperties [Property "overall" $ ensureProperties ps] 	setTitle "propellor: done" 	hFlush stdout 	case r of 		FailedChange -> exitWith (ExitFailure 1) 		_ -> exitWith ExitSuccess -ensureProperties' :: [Property] -> IO Result-ensureProperties' ps = ensure ps NoChange+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

@@ -0,0 +1,16 @@+{-# LANGUAGE PackageImports #-}++module Propellor.Exception where++import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M+import Control.Exception+import Control.Applicative++import Propellor.Types++-- | Catches IO exceptions and returns FailedChange.+catchPropellor :: Propellor Result -> Propellor Result+catchPropellor a = either (\_ -> FailedChange) id <$> tryPropellor a++tryPropellor :: Propellor a -> Propellor (Either IOException a)+tryPropellor = M.try

@@ -1,30 +1,35 @@+{-# 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 :: ActionResult r => Desc -> IO r -> IO r+actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r actionMessage desc a = do-	setTitle $ "propellor: " ++ desc-	hFlush stdout+	liftIO $ do+		setTitle $ "propellor: " ++ desc+		hFlush stdout  	r <- a -	setTitle "propellor: running"-	let (msg, intensity, color) = getActionResult r-	putStr $ desc ++ " ... "-	colorLine intensity color msg-	hFlush stdout+	liftIO $ do+		setTitle "propellor: running"+		let (msg, intensity, color) = getActionResult r+		putStr $ desc ++ " ... "+		colorLine intensity color msg+		hFlush stdout  	return r -warningMessage :: String -> IO ()-warningMessage s = colorLine Vivid Red $ "** warning: " ++ s+warningMessage :: MonadIO m => String -> m ()+warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s  colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do

@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+ module Propellor.PrivData where  import qualified Data.Map as M@@ -7,8 +9,10 @@ import System.Directory import Data.Maybe import Control.Monad+import "mtl" Control.Monad.Reader  import Propellor.Types+import Propellor.Attr import Propellor.Message import Utility.Monad import Utility.PartialPrelude@@ -18,12 +22,15 @@ import Utility.SafeCommand import Utility.Misc -withPrivData :: PrivDataField -> (String -> IO Result) -> IO Result-withPrivData field a = maybe missing a =<< getPrivData field+withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result+withPrivData field a = maybe missing a =<< liftIO (getPrivData field)   where 	missing = do-		warningMessage $ "Missing privdata " ++ show field-		return FailedChange+		host <- getHostName+		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

@@ -1,17 +1,22 @@+{-# LANGUAGE PackageImports #-}+ module Propellor.Property where  import System.Directory import Control.Monad import Data.Monoid+import Control.Monad.IfElse+import "mtl" Control.Monad.Reader  import Propellor.Types+import Propellor.Types.Attr import Propellor.Engine import Utility.Monad -makeChange :: IO () -> IO Result-makeChange a = a >> return MadeChange+makeChange :: IO () -> Propellor Result+makeChange a = liftIO a >> return MadeChange -noChange :: IO Result+noChange :: Propellor Result noChange = return NoChange  -- | Combines a list of properties, resulting in a single property@@ -19,7 +24,7 @@ -- 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+propertyList desc ps = Property desc $ ensureProperties ps  -- | Combines a list of properties, resulting in one property that -- ensures each in turn, stopping on failure.@@ -33,18 +38,29 @@ 			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 = Property (propertyDesc p1) $ do+	r <- ensureProperty p1+	case r of+		FailedChange -> return FailedChange+		_ -> ensureProperty p2+ -- | 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 property flagfile = Property (propertyDesc property) $-	go =<< doesFileExist flagfile+	go =<< liftIO (doesFileExist flagfile)   where 	go True = return NoChange 	go False = do 		r <- ensureProperty property-		when (r == MadeChange) $-			writeFile flagfile ""+		when (r == MadeChange) $ liftIO $ +			unlessM (doesFileExist flagfile) $+				writeFile flagfile "" 		return r  --- | Whenever a change has to be made for a Property, causes a hook@@ -64,13 +80,13 @@  -- | Makes a Property only be performed when a test succeeds. check :: IO Bool -> Property -> Property-check c property = Property (propertyDesc property) $ ifM c+check c property = Property (propertyDesc property) $ ifM (liftIO c) 	( ensureProperty property 	, return NoChange 	)  boolProperty :: Desc -> IO Bool -> Property-boolProperty desc a = Property desc $ ifM a+boolProperty desc a = Property desc $ ifM (liftIO a) 	( return MadeChange 	, return FailedChange 	)@@ -79,17 +95,26 @@ revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Starts a list of Properties-props :: [Property]-props = []+-- | 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 the list.--- Can add both Properties and RevertableProperties.-(&) :: IsProp p => [Property] -> p -> [Property]-ps & p = ps ++ [toProp p]+-- | 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)+ infixl 1 & --- | Adds a property to the list in reverted form.-(!) :: [Property] -> RevertableProperty -> [Property]-ps ! p = ps ++ [toProp $ revert p]+-- | Adds a property to the Host in reverted form.+(!) :: Host -> RevertableProperty -> Host+(Host ps as) ! p = Host (ps ++ [toProp q]) (getAttr q . as)+  where+	q = revert p+ infixl 1 !

@@ -8,6 +8,7 @@  import Propellor import qualified Propellor.Property.File as File+import qualified Propellor.Property.Service as Service import Propellor.Property.File (Line)  sourcesList :: FilePath@@ -46,13 +47,22 @@ kernelOrg :: DebianSuite -> [Line] kernelOrg = binandsrc "http://mirrors.kernel.org/debian" +-- | Only available for Stable and Testing+securityUpdates :: DebianSuite -> [Line]+securityUpdates suite+	| suite == Stable || suite == Testing =+		let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections+		in [l, srcLine l]+	| otherwise = []+ -- | Makes sources.list have a standard content using the mirror CDN, -- with a particular DebianSuite. -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. stdSourcesList :: DebianSuite -> Property-stdSourcesList suite = setSourcesList (debCdn suite ++ kernelOrg suite)+stdSourcesList suite = setSourcesList+	(debCdn suite ++ kernelOrg suite ++ securityUpdates suite) 	`describe` ("standard sources.list for " ++ show suite)  setSourcesList :: [Line] -> Property@@ -147,9 +157,12 @@  -- | Enables unattended upgrades. Revert to disable. unattendedUpgrades :: RevertableProperty-unattendedUpgrades = RevertableProperty (go True) (go False)+unattendedUpgrades = RevertableProperty enable disable   where-	go enabled = (if enabled then installed else removed) ["unattended-upgrades"]+	enable = setup True `before` Service.running "cron"+	disable = setup False++	setup enabled = (if enabled then installed else removed) ["unattended-upgrades"] 		`onChange` reConfigure "unattended-upgrades" 			[("unattended-upgrades/enable_auto_updates" , "boolean", v)] 		`describe` ("unattended upgrades " ++ v)@@ -167,7 +180,14 @@ 	setselections = Property "preseed" $ makeChange $ 		withHandle StdinHandle createProcessSuccess 			(proc "debconf-set-selections" []) $ \h -> do-				forM_ vals $ \(template, tmpltype, value) ->-					hPutStrLn h $ unwords [package, template, tmpltype, value]+				forM_ vals $ \(tmpl, tmpltype, value) ->+					hPutStrLn h $ unwords [package, tmpl, tmpltype, value] 				hClose h 	reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]++-- | Ensures that a service is installed and running.+--+-- Assumes that there is a 1:1 mapping between service names and apt+-- package names.+serviceInstalledRunning :: Package -> Property+serviceInstalledRunning svc = Service.running svc `requires` installed [svc]

@@ -1,17 +1,17 @@+{-# LANGUAGE PackageImports #-}+ module Propellor.Property.Cmd ( 	cmdProperty, 	cmdProperty', 	scriptProperty, 	userScriptProperty,-	serviceRunning, ) where -import Control.Monad import Control.Applicative import Data.List+import "mtl" Control.Monad.Reader  import Propellor.Types-import Propellor.Engine import Utility.Monad import Utility.SafeCommand import Utility.Env@@ -25,7 +25,7 @@ -- | 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 $ do+cmdProperty' cmd params env = Property desc $ liftIO $ do 	env' <- addEntries env <$> getEnvironment 	ifM (boolSystemEnv cmd (map Param params) (Just env')) 		( return MadeChange@@ -46,14 +46,3 @@ userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user]   where 	shellcmd = intercalate " ; " ("set -e" : "cd" : script)---- | Ensures that a service is running.------ 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.-serviceRunning :: String -> Property-serviceRunning svc = Property ("running " ++ svc) $ do-	void $ ensureProperty $-		scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]-	return NoChange

@@ -18,8 +18,7 @@ 	, "" 	, times ++ "\t" ++ user ++ "\t" ++ "cd " ++ cddir ++ " && " ++ command 	]-	`requires` Apt.installed ["cron"]-	`requires` serviceRunning "cron"+	`requires` Apt.serviceInstalledRunning "cron" 	`describe` ("cronned " ++ desc)  -- | Installs a cron job, and runs it niced and ioniced.

@@ -0,0 +1,63 @@+module Propellor.Property.Dns where++import Propellor+import Propellor.Property.File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++namedconf :: FilePath+namedconf = "/etc/bind/named.conf.local"++data Zone = Zone+	{ zdomain :: Domain+	, ztype :: Type+	, zfile :: FilePath+	, zmasters :: [IPAddr]+	, zconfiglines :: [String]+	}++zoneDesc :: Zone -> String+zoneDesc z = zdomain z ++ " (" ++ show (ztype z) ++ ")"++type IPAddr = String++type Domain = String++data Type = Master | Secondary+	deriving (Show, Eq)++secondary :: Domain -> [IPAddr] -> Zone+secondary domain masters = Zone+	{ zdomain = domain+	, ztype = Secondary+	, zfile = "db." ++ domain+	, zmasters = masters+	, zconfiglines = ["allow-transfer { }"]+	}++zoneStanza :: Zone -> [Line]+zoneStanza z =+	[ "// automatically generated by propellor"+	, "zone \"" ++ zdomain z ++ "\" {"+	, cfgline "type" (if ztype z == Master then "master" else "slave")+	, cfgline "file" ("\"" ++ zfile z ++ "\"")+	] +++	(if null (zmasters z) then [] else mastersblock) +++	(map (\l -> "\t" ++ l ++ ";") (zconfiglines z)) +++	[ "};"+	, ""+	]+  where+	cfgline f v = "\t" ++ f ++ " " ++ v ++ ";"+	mastersblock =+		[ "\tmasters {" ] +++		(map (\ip -> "\t\t" ++ ip ++ ";") (zmasters z)) +++		[ "\t};" ]++-- | Rewrites the whole named.conf.local file to serve the specificed+-- zones.+zones :: [Zone] -> Property+zones zs = hasContent namedconf (concatMap zoneStanza zs)+	`describe` ("dns server for zones: " ++ unwords (map zoneDesc zs))+	`requires` Apt.serviceInstalledRunning "bind9"+	`onChange` Service.reloaded "bind9"

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}  -- | Docker support for propellor --@@ -9,6 +9,7 @@  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@@ -32,6 +33,25 @@ 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.@@ -39,44 +59,61 @@ -- Reverting this property ensures that the container is stopped and -- removed. docked-	:: (HostName -> ContainerName -> Maybe (Container))-	-> HostName+	:: [Host] 	-> ContainerName 	-> RevertableProperty-docked findc hn cn = findContainer findc hn cn $-	\(Container image containerprops) ->-		let setup = provisionContainer cid-				`requires`-			runningContainer cid image containerprops-				`requires`-			installed-		    teardown = combineProperties ("undocked " ++ fromContainerId cid)-		    	[ stoppedContainer cid+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) $-				report <$> mapM id+				liftIO $ report <$> mapM id 					[ removeContainer cid 					, removeImage image 					] 			]-		in RevertableProperty setup teardown-  where-  	cid = ContainerId hn cn  findContainer-	:: (HostName -> ContainerName -> Maybe (Container))-	-> HostName+	:: [Host]+	-> ContainerId 	-> ContainerName-	-> (Container -> RevertableProperty)-	-> RevertableProperty-findContainer findc hn cn mk = case findc hn cn of-	Nothing -> RevertableProperty cantfind cantfind-	Just container -> mk container+	-> (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-  	cid = ContainerId hn cn-	cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do-		warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid+	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@@ -90,34 +127,11 @@ 	]   where 	gccontainers = Property "docker containers garbage collected" $-		report <$> (mapM removeContainer =<< listContainers AllContainers)+		liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) 	gcimages = Property "docker images garbage collected" $ do-		report <$> (mapM removeImage =<< listImages)---- | Pass to defaultMain to add docker containers.--- You need to provide the function mapping from--- HostName and ContainerName to the Container to use.-containerProperties-	:: (HostName -> ContainerName -> Maybe (Container))-	-> (HostName -> Maybe [Property])-containerProperties findcontainer = \h -> case toContainerId h of-	Nothing -> Nothing-	Just cid@(ContainerId hn cn) ->-		case findcontainer hn cn of-			Nothing -> Nothing-			Just (Container _ cprops) -> -				Just $ map (containerDesc cid) $-					fromContainerized cprops---- | This type is used to configure a docker container.--- It has an image, and a list of Properties, but these--- properties are Containerized; they can specify--- things about the container's configuration, in--- addition to properties of the system inside the--- container.-data Container = Container Image [Containerized Property]+		liftIO $ report <$> (mapM removeImage =<< listImages) -data Containerized a = Containerized [HostName -> RunParam] a+data Container = Container Image [RunParam]  -- | Parameters to pass to `docker run` when creating a container. type RunParam = String@@ -125,62 +139,50 @@ -- | A docker image, that can be used to run a container. type Image = String --- | 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---- | Lift a Property to apply inside a container.-inside1 :: Property -> Containerized Property-inside1 = Containerized []--inside :: [Property] -> Containerized Property-inside = Containerized [] . combineProperties "provision"- -- | Set custom dns server for container.-dns :: String -> Containerized Property+dns :: String -> AttrProperty dns = runProp "dns"  -- | Set container host name.-hostname :: String -> Containerized Property+hostname :: String -> AttrProperty hostname = runProp "hostname"  -- | Set name for container. (Normally done automatically.)-name :: String -> Containerized Property+name :: String -> AttrProperty name = runProp "name"  -- | Publish a container's port to the host -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort)-publish :: String -> Containerized Property+publish :: String -> AttrProperty publish = runProp "publish"  -- | Username or UID for container.-user :: String -> Containerized Property+user :: String -> AttrProperty user = runProp "user"  -- | Mount a volume -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- With just a directory, creates a volume in the container.-volume :: String -> Containerized Property+volume :: String -> AttrProperty volume = runProp "volume"  -- | Mount a volume from the specified container into the current -- container.-volumes_from :: ContainerName -> Containerized Property+volumes_from :: ContainerName -> AttrProperty volumes_from cn = genProp "volumes-from" $ \hn -> 	fromContainerId (ContainerId hn cn)  -- | Work dir inside the container. -workdir :: String -> Containerized Property+workdir :: String -> AttrProperty workdir = runProp "workdir"  -- | Memory limit for container. --Format: <number><optional unit>, where unit = b, k, m or g-memory :: String -> Containerized Property+memory :: String -> AttrProperty memory = runProp "memory"  -- | Link with another container on the same host.-link :: ContainerName -> ContainerAlias -> Containerized Property+link :: ContainerName -> ContainerAlias -> AttrProperty link linkwith alias = genProp "link" $ \hn -> 	fromContainerId (ContainerId hn linkwith) ++ ":" ++ alias @@ -199,16 +201,6 @@ data ContainerIdent = ContainerIdent Image HostName ContainerName [RunParam] 	deriving (Read, Show, Eq) -getRunParams :: HostName -> [Containerized a] -> [RunParam]-getRunParams hn l = concatMap get l-  where-	get (Containerized ps _) = map (\a -> a hn ) ps--fromContainerized :: forall a. [Containerized a] -> [a]-fromContainerized l = map get l-  where-	get (Containerized _ a) = a- ident2id :: ContainerIdent -> ContainerId ident2id (ContainerIdent _ hn cn _) = ContainerId hn cn @@ -226,32 +218,32 @@ fromContainerId :: ContainerId -> String fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix +containerHostName :: ContainerId -> HostName+containerHostName (ContainerId _ cn) = cn2hn cn+ myContainerSuffix :: String myContainerSuffix = ".propellor" -containerFrom :: Image -> [Containerized Property] -> Container-containerFrom = Container- containerDesc :: ContainerId -> Property -> Property containerDesc cid p = p `describe` desc   where 	desc = "[" ++ fromContainerId cid ++ "] " ++ propertyDesc p -runningContainer :: ContainerId -> Image -> [Containerized Property] -> Property-runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc cid $ Property "running" $ do-	l <- listContainers RunningContainers+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 <- getrunningident+			runningident <- liftIO $ getrunningident 			if runningident == Just ident-				then return NoChange+				then noChange 				else do-					void $ stopContainer cid+					void $ liftIO $ stopContainer cid 					restartcontainer-		else ifM (elem cid <$> listContainers AllContainers)+		else ifM (liftIO $ elem cid <$> listContainers AllContainers) 			( restartcontainer 			, go image 			)@@ -259,8 +251,8 @@ 	ident = ContainerIdent image hn cn runps  	restartcontainer = do-		oldimage <- fromMaybe image <$> commitContainer cid-		void $ removeContainer cid+		oldimage <- liftIO $ fromMaybe image <$> commitContainer cid+		void $ liftIO $ removeContainer cid 		go oldimage  	getrunningident :: IO (Maybe ContainerIdent)@@ -271,19 +263,12 @@ 	extractident :: [Resp] -> Maybe ContainerIdent 	extractident = headMaybe . catMaybes . map readish . catMaybes . map getStdout -	runps = getRunParams hn $ containerprops ++-		-- 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)-		]-	 	go img = do-		clearProvisionedFlag cid-		createDirectoryIfMissing True (takeDirectory $ identFile cid)-		shim <- Shim.setup (localdir </> "propellor") (localdir </> shimdir cid)-		writeFile (identFile cid) (show ident)+		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]@@ -317,7 +302,7 @@ 		-- 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 $ fromContainerId 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@@ -339,14 +324,14 @@ -- being run. So, retry connections to the client for up to -- 1 minute. provisionContainer :: ContainerId -> Property-provisionContainer cid = containerDesc cid $ Property "provision" $ do+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 $ fromContainerId cid]+	params = ["--continue", show $ Chain $ containerHostName cid]  	go lastline (v:rest) = case v of 		StdoutLine s -> do@@ -372,8 +357,8 @@  stoppedContainer :: ContainerId -> Property stoppedContainer cid = containerDesc cid $ Property desc $ -	ifM (elem cid <$> listContainers RunningContainers)-		( cleanup `after` ensureProperty +	ifM (liftIO $ elem cid <$> listContainers RunningContainers)+		( liftIO cleanup `after` ensureProperty  			(boolProperty desc $ stopContainer cid) 		, return NoChange 		)@@ -420,17 +405,18 @@ listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Containerized Property-runProp field val = Containerized-	[\_ -> "--" ++ param]-	(Property (param) (return NoChange))+runProp :: String -> RunParam -> AttrProperty+runProp field val = AttrProperty prop $ \attr ->+	attr { _dockerRunParams = _dockerRunParams attr ++ [\_ -> "--"++param] }   where 	param = field++"="++val+	prop = Property (param) (return NoChange) -genProp :: String -> (HostName -> RunParam) -> Containerized Property-genProp field mkval = Containerized-	[\h -> "--" ++ field ++ "=" ++ mkval h]-	(Property field (return NoChange))+genProp :: String -> (HostName -> RunParam) -> AttrProperty+genProp field mkval = AttrProperty prop $ \attr ->+	attr { _dockerRunParams = _dockerRunParams attr ++ [\hn -> "--"++field++"=" ++ mkval hn] }+  where+	prop = Property field (return NoChange)  -- | The ContainerIdent of a container is written to -- /.propellor-ident inside it. This can be checked to see if

@@ -11,6 +11,13 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f) 	(\_oldcontent -> newcontent) f +-- | Ensures a file has contents that comes from PrivData.+-- Note: Does not do anything with the permissions of the file to prevent+-- it from being seen.+hasPrivContent :: FilePath -> Property+hasPrivContent f = Property ("privcontent " ++ f) $+	withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)+ -- | Ensures that a line is present in a file, adding it to the end if not. containsLine :: FilePath -> Line -> Property f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f@@ -31,10 +38,10 @@ 	makeChange $ nukeFile f  fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property-fileProperty desc a f = Property desc $ go =<< doesFileExist f+fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)   where 	go True = do-		ls <- lines <$> readFile f+		ls <- liftIO $ lines <$> readFile f 		let ls' = a ls 		if ls' == ls 			then noChange@@ -51,3 +58,13 @@ 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

@@ -0,0 +1,48 @@+module Propellor.Property.Git where++import Propellor+import Propellor.Property.File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++import Data.List++-- | Exports all git repos in a directory (that user nobody can read)+-- using git-daemon, run from inetd.+--+-- Note that reverting this property does not remove or stop inetd.+daemonRunning :: FilePath -> RevertableProperty+daemonRunning exportdir = RevertableProperty setup unsetup+  where+	setup = containsLine conf (mkl "tcp4")+		`requires`+		containsLine conf (mkl "tcp6")+		`requires`+		dirExists exportdir+		`requires`+		Apt.serviceInstalledRunning "openbsd-inetd"+		`onChange`+		Service.running "openbsd-inetd"+		`describe` ("git-daemon exporting " ++ exportdir)+	unsetup = lacksLine conf (mkl "tcp4")+		`requires`+		lacksLine conf (mkl "tcp6")+		`onChange`+		Service.reloaded "openbsd-inetd"++	conf = "/etc/inetd.conf"++	mkl tcpv = intercalate "\t"+		[ "git"+		, "stream"+		, tcpv+		, "nowait"+		, "nobody"+		, "/usr/bin/git"+		, "git"+		, "daemon"+		, "--inetd"+		, "--export-all"+		, "--base-path=" ++ exportdir+		, exportdir+		]

@@ -3,21 +3,24 @@ import Propellor import qualified Propellor.Property.File as File --- | Sets the hostname. Configures both /etc/hostname and the current--- hostname.+-- | Ensures that the hostname is set to the HostAttr value.+-- Configures both /etc/hostname and the current hostname. ----- When provided with a FQDN, also configures /etc/hosts,+-- 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).-set :: HostName -> Property-set hostname = combineProperties desc go-	`onChange` cmdProperty "hostname" [host]+sane :: Property+sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)++setTo :: HostName -> Property+setTo hn = combineProperties desc go+	`onChange` cmdProperty "hostname" [basehost]   where-	desc = "hostname " ++ hostname-	(host, domain) = separate (== '.') hostname+	desc = "hostname " ++ hn+	(basehost, domain) = separate (== '.') hn  	go = catMaybes-		[ Just $ "/etc/hostname" `File.hasContent` [host]+		[ Just $ "/etc/hostname" `File.hasContent` [basehost] 		, if null domain 			then Nothing  			else Just $ File.fileProperty desc@@ -25,7 +28,7 @@ 		] 	 	hostip = "127.0.1.1"-	hostline = hostip ++ "\t" ++ hostname ++ " " ++ host+	hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost  	addhostline ls = hostline : filter (not . hashostip) ls 	hashostip l = headMaybe (words l) == Just hostip

@@ -20,6 +20,7 @@ 		, "\taddress 2002:5044:5531::1" 		, "\tnetmask 64" 		, "\tgateway ::192.88.99.1"+		, "auto sit0" 		, "# End automatically added by propeller" 		] 

@@ -0,0 +1,26 @@+module Propellor.Property.OpenId where++import Propellor+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Service as Service++import Data.List++providerFor :: [UserName] -> String -> Property+providerFor users baseurl = propertyList desc $+	[ Apt.serviceInstalledRunning "apache2"+	, Apt.installed ["simpleid"]+		`onChange` Service.restarted "apache2"+	, File.fileProperty desc+		(map setbaseurl) "/etc/simpleid/config.inc"+	] ++ map identfile users+  where+	identfile u = File.hasPrivContent $ concat+		[ "/var/lib/simpleid/identities/", u, ".identity" ]+	url = "http://"++baseurl++"/simpleid"+	desc = "openid provider " ++ url+	setbaseurl l+		| "SIMPLEID_BASE_URL" `isInfixOf` l = +			"define('SIMPLEID_BASE_URL', '"++url++"');"+		| otherwise = l

@@ -0,0 +1,67 @@+module Propellor.Property.Scheduled+	( period+	, periodParse+	, Recurrance(..)+	, WeekDay+	, MonthDay+	, YearDay+	) where++import Propellor+import Utility.Scheduled++import Data.Time.Clock+import Data.Time.LocalTime+import qualified Data.Map as M++-- | Makes a Property only be checked every so often.+--+-- This uses the description of the Property to keep track of when it was+-- last run.+period :: Property -> Recurrance -> Property+period prop recurrance = Property desc $ do+	lasttime <- liftIO $ getLastChecked (propertyDesc prop)+	nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime+	t <- liftIO localNow+	if Just t >= nexttime+		then do+			r <- ensureProperty prop+			liftIO $ setLastChecked t (propertyDesc prop)+			return r+		else noChange+  where+	schedule = Schedule recurrance AnyTime+	desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"++-- | Like period, but parse a human-friendly string.+periodParse :: Property -> String -> Property+periodParse prop s = case toRecurrance s of+	Just recurrance -> period prop recurrance+	Nothing -> Property "periodParse" $ do+		liftIO $ warningMessage $ "failed periodParse: " ++ s+		noChange++lastCheckedFile :: FilePath+lastCheckedFile = localdir </> ".lastchecked"++getLastChecked :: Desc -> IO (Maybe LocalTime)+getLastChecked desc = M.lookup desc <$> readLastChecked++localNow :: IO LocalTime+localNow = do+	now <- getCurrentTime+	tz <- getTimeZone now+	return $ utcToLocalTime tz now++setLastChecked :: LocalTime -> Desc -> IO ()+setLastChecked time desc = do+	m <- readLastChecked+	writeLastChecked (M.insert desc time m)++readLastChecked :: IO (M.Map Desc LocalTime)+readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go+  where+	go = readish <$> readFile lastCheckedFile++writeLastChecked :: M.Map Desc LocalTime -> IO ()+writeLastChecked = writeFile lastCheckedFile . show

@@ -0,0 +1,31 @@+module Propellor.Property.Service where++import Propellor+import Utility.SafeCommand++type ServiceName = String++-- | Ensures that a service is running. Does not ensure that+-- any package providing that service is installed. See+-- Apt.serviceInstalledRunning+--+-- Note that due to the general poor state of init scripts, the best+-- we can do is try to start the service, and if it fails, assume+-- this means it's already running.+running :: ServiceName -> Property+running svc = Property ("running " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " start >/dev/null 2>&1 || true"]+	return NoChange++restarted :: ServiceName -> Property+restarted svc = Property ("restarted " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " restart >/dev/null 2>&1 || true"]+	return NoChange++reloaded :: ServiceName -> Property+reloaded svc = Property ("reloaded " ++ svc) $ do+	void $ ensureProperty $+		scriptProperty ["service " ++ shellEscape svc ++ " reload >/dev/null 2>&1 || true"]+	return NoChange

@@ -24,7 +24,7 @@ 	, Apt.buildDep ["git-annex"] 	, Apt.installed ["git", "rsync", "moreutils", "ca-certificates", 		"liblockfile-simple-perl", "cabal-install", "vim", "less"]-	, serviceRunning "cron" `requires` Apt.installed ["cron"]+	, Apt.serviceInstalledRunning "cron" 	, User.accountFor builduser 	, check (not <$> doesDirectoryExist gitbuilderdir) $ userScriptProperty builduser 		[ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir@@ -44,12 +44,13 @@ 		let f = homedir </> "rsyncpassword" 		if rsyncupload  			then withPrivData (Password builduser) $ \p -> do-				oldp <- catchDefaultIO "" $ readFileStrict f+				oldp <- liftIO $ catchDefaultIO "" $+					readFileStrict f 				if p /= oldp 					then makeChange $ writeFile f p 					else noChange 			else do-				ifM (doesFileExist f)+				ifM (liftIO $ doesFileExist f) 					( noChange 					, makeChange $ writeFile f "no password configured" 					)

@@ -8,8 +8,8 @@ -- | 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 =<< homedir user)-		`requires` Apt.installed ["git", "myrepos"]+	Property ("githome " ++ user) (go =<< liftIO (homedir user))+		`requires` Apt.installed ["git"]   where  	go Nothing = noChange 	go (Just home) = do@@ -20,7 +20,7 @@ 				moveout tmpdir home 			, Property "rmdir" $ makeChange $ void $ 				catchMaybeIO $ removeDirectory tmpdir-			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups"]+			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"] 			] 	moveout tmpdir home = do 		fs <- dirContents tmpdir

@@ -6,8 +6,8 @@ import Propellor import qualified Propellor.Property.Apt as Apt -oldUseNetshellBox :: Property-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $+oldUseNetShellBox :: Property+oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $ 	propertyList ("olduse.net shellbox") 		[ Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") 			`describe` "olduse.net build deps"

@@ -53,7 +53,7 @@ 	`onChange` restartSshd   where 	prop = Property "ssh unique host keys" $ do-		void $ boolSystem "sh"+		void $ liftIO $ boolSystem "sh" 			[ Param "-c" 			, Param "rm -f /etc/ssh/ssh_host_*" 			]

@@ -13,7 +13,7 @@ enabledFor user = Property desc go `requires` Apt.installed ["sudo"]   where 	go = do-		locked <- isLockedPassword user+		locked <- liftIO $ isLockedPassword user 		ensureProperty $ 			fileProperty desc 				(modify locked . filter (wanted locked))

@@ -27,7 +27,7 @@ 	createDirectoryIfMissing True dir 	modifyFileMode dir (removeModes otherGroupModes) 	s <- socket AF_UNIX Stream defaultProtocol-	bind s (SockAddrUnix namedpipe)+	bindSocket s (SockAddrUnix namedpipe) 	listen s 2 	forever $ do 		(client, _addr) <- accept s

@@ -1,19 +1,74 @@-module Propellor.Types where+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-} +module Propellor.Types+	( Host(..)+	, Attr+	, HostName+	, UserName+	, GroupName+	, Propellor(..)+	, Property(..)+	, RevertableProperty(..)+	, AttrProperty(..)+	, IsProp+	, describe+	, toProp+	, getAttr+	, requires+	, Desc+	, Result(..)+	, System(..)+	, Distribution(..)+	, DebianSuite(..)+	, Release+	, Architecture+	, ActionResult(..)+	, CmdLine(..)+	, PrivDataField(..)+	) where+ import Data.Monoid+import Control.Applicative import System.Console.ANSI+import "mtl" Control.Monad.Reader+import "MonadCatchIO-transformers" Control.Monad.CatchIO -type HostName = String+import Propellor.Types.Attr++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 }+	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 	-- | must be idempotent; may run repeatedly-	, propertySatisfy :: IO Result+	, propertySatisfy :: Propellor Result 	} +-- | A property that can be reverted. data RevertableProperty = RevertableProperty Property Property +-- | A property that affects the Attr.+data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)+ class IsProp p where 	-- | Sets description. 	describe :: p -> Desc -> p@@ -21,6 +76,7 @@ 	-- | Indicates that the first property can only be satisfied 	-- once the second one is. 	requires :: p -> Property -> p+	getAttr :: p -> (Attr -> Attr)  instance IsProp Property where 	describe p d = p { propertyDesc = d }@@ -30,6 +86,7 @@ 		case r of 			FailedChange -> return FailedChange 			_ -> propertySatisfy x+	getAttr _ = id  instance IsProp RevertableProperty where 	-- | Sets the description of both sides.@@ -38,7 +95,14 @@ 	toProp (RevertableProperty p1 _) = p1 	(RevertableProperty p1 p2) `requires` y = 		RevertableProperty (p1 `requires` y) p2+	getAttr _ = id +instance IsProp AttrProperty where+	describe (AttrProperty p a) d = AttrProperty (describe p d) a+	toProp (AttrProperty p _) = toProp p+	(AttrProperty p a) `requires` y = AttrProperty (p `requires` y) a+	getAttr (AttrProperty _ a) = a+ type Desc = String  data Result = NoChange | MadeChange | FailedChange@@ -63,7 +127,7 @@ 	deriving (Show)  data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release-	deriving (Show)+	deriving (Show, Eq)  type Release = String @@ -100,6 +164,7 @@ 	= DockerAuthentication 	| SshPrivKey UserName 	| Password UserName+	| PrivFile FilePath 	deriving (Read, Show, Ord, Eq)  

@@ -0,0 +1,36 @@+module Propellor.Types.Attr where++import qualified Data.Set as S++-- | The attributes of a host. For example, its hostname.+data Attr = Attr+	{ _hostname :: HostName+	, _cnames :: S.Set Domain++	, _dockerImage :: Maybe String+	, _dockerRunParams :: [HostName -> String]+	}++instance Eq Attr where+	x == y = and+		[ _hostname x == _hostname y+		, _cnames x == _cnames 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+		, "cnames " ++ show (_cnames 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 []++type HostName = String+type Domain = String

@@ -2,15 +2,19 @@   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.-* --spin needs 4 ssh connections when bootstrapping a new host-  that does not have the git repo yet. Should be possible to get that-  down to 1. * Currently only Debian and derivatives are supported by most Properties.-  One way to improve that would be to parameterize Properties with a-  Distribution witness.+  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. * Should properties be a tree rather than a list?-* Only make docker garbage collection run once a day or something-  to avoid GC after a temp fail.+* Need a way for a dns server host to look at the properties of +  the other hosts and generate a zone file. For example, mapping+  openid.kitenet.net to a CNAME to clam.kitenet.net, which is where+  the docker container for that service is located. Moving containers+  to a different host, or duplicating a container on multiple hosts+  would then update DNS too+* 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.

@@ -0,0 +1,52 @@+{- QuickCheck with additional instances+ -+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Utility.QuickCheck+	( module X+	, module Utility.QuickCheck+	) where++import Test.QuickCheck as X+import Data.Time.Clock.POSIX+import System.Posix.Types+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Applicative++instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where+	arbitrary = M.fromList <$> arbitrary++instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where+	arbitrary = S.fromList <$> arbitrary++{- Times before the epoch are excluded. -}+instance Arbitrary POSIXTime where+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral++instance Arbitrary EpochTime where+	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral++{- Pids are never negative, or 0. -}+instance Arbitrary ProcessID where+	arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)++{- Inodes are never negative. -}+instance Arbitrary FileID where+	arbitrary = nonNegative arbitrarySizedIntegral++{- File sizes are never negative. -}+instance Arbitrary FileOffset where+	arbitrary = nonNegative arbitrarySizedIntegral++nonNegative :: (Num a, Ord a) => Gen a -> Gen a+nonNegative g = g `suchThat` (>= 0)++positive :: (Num a, Ord a) => Gen a -> Gen a+positive g = g `suchThat` (> 0)

@@ -0,0 +1,358 @@+{- scheduled activities+ - + - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Utility.Scheduled (+	Schedule(..),+	Recurrance(..),+	ScheduledTime(..),+	NextTime(..),+	WeekDay,+	MonthDay,+	YearDay,+	nextTime,+	startTime,+	fromSchedule,+	fromScheduledTime,+	toScheduledTime,+	fromRecurrance,+	toRecurrance,+	toSchedule,+	parseSchedule,+	prop_schedule_roundtrips+) where++import Utility.Data+import Utility.QuickCheck+import Utility.PartialPrelude+import Utility.Misc++import Control.Applicative+import Data.List+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.Calendar+import Data.Time.Calendar.WeekDate+import Data.Time.Calendar.OrdinalDate+import Data.Tuple.Utils+import Data.Char++{- Some sort of scheduled event. -}+data Schedule = Schedule Recurrance ScheduledTime+  deriving (Eq, Read, Show, Ord)++data Recurrance+	= Daily+	| Weekly (Maybe WeekDay)+	| Monthly (Maybe MonthDay)+	| Yearly (Maybe YearDay)+	| Divisible Int Recurrance+	-- ^ Days, Weeks, or Months of the year evenly divisible by a number.+	-- (Divisible Year is years evenly divisible by a number.)+  deriving (Eq, Read, Show, Ord)++type WeekDay = Int+type MonthDay = Int+type YearDay = Int++data ScheduledTime+	= AnyTime+	| SpecificTime Hour Minute+  deriving (Eq, Read, Show, Ord)++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. -}+data NextTime+	= NextTimeExactly LocalTime+	| NextTimeWindow LocalTime LocalTime+  deriving (Eq, Read, Show)++startTime :: NextTime -> LocalTime+startTime (NextTimeExactly t) = t+startTime (NextTimeWindow t _) = t++nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)+nextTime schedule lasttime = do+	now <- getCurrentTime+	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. -}+calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime+calcNextTime (Schedule recurrance scheduledtime) lasttime currenttime+	| scheduledtime == AnyTime = do+		next <- findfromtoday True+		return $ case next of+			NextTimeWindow _ _ -> next+			NextTimeExactly t -> window (localDay t) (localDay t)+	| otherwise = NextTimeExactly . startTime <$> findfromtoday False+  where+  	findfromtoday anytime = findfrom recurrance afterday today+	  where+	  	today = localDay currenttime+		afterday = sameaslastday || toolatetoday+		toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime+		sameaslastday = lastday == Just today+	lastday = localDay <$> lasttime+	nexttime = case scheduledtime of+		AnyTime -> TimeOfDay 0 0 0+		SpecificTime h m -> TimeOfDay h m 0+	exactly d = NextTimeExactly $ LocalTime d nexttime+	window startd endd = NextTimeWindow+		(LocalTime startd nexttime)+		(LocalTime endd (TimeOfDay 23 59 0))+	findfrom r afterday day = case r of+		Daily+			| afterday -> Just $ exactly $ addDays 1 day+			| otherwise -> Just $ exactly day+		Weekly Nothing+			| afterday -> skip 1+			| otherwise -> case (wday <$> lastday, wday day) of+				(Nothing, _) -> Just $ window day (addDays 6 day)+				(Just old, curr)+					| old == curr -> Just $ window day (addDays 6 day)+					| 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)+			| 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)+			| 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+			| otherwise -> Just $ exactly $+				addDays (fromIntegral $ (w - wday day) `mod` 7) day+		Monthly (Just m)+			| m < 0 || m > maxmday -> Nothing+			-- TODO can be done more efficiently than recursing+			| m == mday day -> if afterday+				then skip 1+				else Just $ exactly day+			| otherwise -> skip 1+		Yearly (Just y)+			| y < 0 || y > maxyday -> Nothing+			| y == yday day -> if afterday+				then skip 365+				else Just $ exactly day+			| 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+	  where+	  	skip n = findfrom r False (addDays n day)+	  	handlediv n r' getval mmax+			| n > 0 && maybe True (n <=) mmax =+				findfromwhere r' (divisible n . getval) afterday day+			| otherwise = Nothing+	findfromwhere r p afterday day+		| maybe True (p . getday) next = next+		| otherwise = maybe Nothing (findfromwhere r p True . getday) next+	  where+		next = findfrom r afterday day+		getday = localDay . startTime+	divisible n v = v `rem` n == 0++endOfMonth :: Day -> Day+endOfMonth day =+	let (y,m,_d) = toGregorian day+	in fromGregorian y m (gregorianMonthLength y m)++endOfYear :: Day -> Day+endOfYear day =+	let (y,_m,_d) = toGregorian day+	in endOfMonth (fromGregorian y maxmnum 1)++-- extracting various quantities from a Day+wday :: Day -> Int+wday = thd3 . toWeekDate+wnum :: Day -> Int+wnum = snd3 . toWeekDate+mday :: Day -> Int+mday = thd3 . toGregorian+mnum :: Day -> Int+mnum = snd3 . toGregorian+yday :: Day -> Int+yday = snd . toOrdinalDate+ynum :: Day -> Int+ynum = fromIntegral . fst . toOrdinalDate++{- Calendar max and mins. -}+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+maxwday = 7++fromRecurrance :: Recurrance -> String+fromRecurrance (Divisible n r) =+	fromRecurrance' (++ "s divisible by " ++ show n) r+fromRecurrance r = fromRecurrance' ("every " ++) r++fromRecurrance' :: (String -> String) -> Recurrance -> String+fromRecurrance' a Daily = a "day"+fromRecurrance' a (Weekly n) = onday n (a "week")+fromRecurrance' a (Monthly n) = onday n (a "month")+fromRecurrance' a (Yearly n) = onday n (a "year")+fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used++onday :: Maybe Int -> String -> String+onday (Just n) s = "on day " ++ show n ++ " of " ++ s+onday Nothing s = s++toRecurrance :: String -> Maybe Recurrance+toRecurrance s = case words s of+	("every":"day":[]) -> Just Daily+	("on":"day":sd:"of":"every":something:[]) -> withday sd something+	("every":something:[]) -> noday something+	("days":"divisible":"by":sn:[]) -> +		Divisible <$> getdivisor sn <*> pure Daily+	("on":"day":sd:"of":something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> withday sd something+	("every":something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> noday something+	(something:"divisible":"by":sn:[]) -> +		Divisible+			<$> getdivisor sn+			<*> noday something+	_ -> Nothing+  where+	constructor "week" = Just Weekly+	constructor "month" = Just Monthly+	constructor "year" = Just Yearly+	constructor u+		| "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u+		| otherwise = Nothing+  	withday sd u = do+		c <- constructor u+		d <- readish sd+		Just $ c (Just d)+	noday u = do+		c <- constructor u+		Just $ c Nothing+	getdivisor sn = do+		n <- readish sn+		if n > 0+			then Just n+			else Nothing++fromScheduledTime :: ScheduledTime -> String+fromScheduledTime AnyTime = "any time"+fromScheduledTime (SpecificTime h m) = +	show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm+  where+  	pad n s = take (n - length s) (repeat '0') ++ s+	(h', ampm)+		| h == 0 = (12, "AM")+		| h < 12 = (h, "AM")+		| h == 12 = (h, "PM")+		| otherwise = (h - 12, "PM")++toScheduledTime :: String -> Maybe ScheduledTime+toScheduledTime "any time" = Just AnyTime+toScheduledTime v = case words v of+	(s:ampm:[])+		| map toUpper ampm == "AM" ->+			go s h0+		| map toUpper ampm == "PM" ->+			go s (\h -> (h0 h) + 12)+		| otherwise -> Nothing+	(s:[]) -> go s id+	_ -> Nothing+  where+  	h0 h+		| h == 12 = 0+		| otherwise = h+  	go :: String -> (Int -> Int) -> Maybe ScheduledTime+	go s adjust =+		let (h, m) = separate (== ':') s+		in SpecificTime+			<$> (adjust <$> readish h)+			<*> if null m then Just 0 else readish m++fromSchedule :: Schedule -> String+fromSchedule (Schedule recurrance scheduledtime) = unwords+	[ fromRecurrance recurrance+	, "at"+	, fromScheduledTime scheduledtime+	]++toSchedule :: String -> Maybe Schedule+toSchedule = eitherToMaybe . parseSchedule++parseSchedule :: String -> Either String Schedule+parseSchedule s = do+	r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right+		(toRecurrance recurrance)+	t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right+		(toScheduledTime scheduledtime)+	Right $ Schedule r t+  where+	(rws, tws) = separate (== "at") (words s)+	recurrance = unwords rws+	scheduledtime = unwords tws++instance Arbitrary Schedule where+	arbitrary = Schedule <$> arbitrary <*> arbitrary++instance Arbitrary ScheduledTime where+	arbitrary = oneof+		[ pure AnyTime+		, SpecificTime +			<$> choose (0, 23)+			<*> choose (1, 59)+		]++instance Arbitrary Recurrance where+	arbitrary = oneof+		[ pure Daily+		, Weekly <$> arbday+		, Monthly <$> arbday+		, Yearly <$> arbday+		, Divisible+			<$> positive arbitrary+			<*> oneof -- no nested Divisibles+				[ pure Daily+				, Weekly <$> arbday+				, Monthly <$> arbday+				, Yearly <$> arbday+				]+		]+	  where+	  	arbday = oneof+			[ Just <$> nonNegative arbitrary+			, pure Nothing+			]++prop_schedule_roundtrips :: Schedule -> Bool+prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s

@@ -2,6 +2,7 @@  import Propellor import Propellor.CmdLine+import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network@@ -12,124 +13,167 @@ import qualified Propellor.Property.Hostname as Hostname --import qualified Propellor.Property.Reboot as Reboot import qualified Propellor.Property.Tor as Tor+import qualified Propellor.Property.Dns as Dns+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.SiteSpecific.GitHome as GitHome import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites-import Data.List -main :: IO ()-main = defaultMain [host, Docker.containerProperties container]+hosts :: [Host]+hosts =+	-- My laptop+	[ host "darkstar.kitenet.net"+		& Docker.configured+		& Apt.buildDep ["git-annex"] `period` Daily --- | This is where the system's HostName, either as returned by uname--- or one specified on the command line, is converted into a list of--- Properties for that system.------ Edit this to configure propellor!-host :: HostName -> Maybe [Property]--- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.-host hostname@"clam.kitenet.net" = standardSystem Unstable $ props-	& cleanCloudAtCost hostname-	& Apt.unattendedUpgrades-	& Network.ipv6to4-	& Apt.installed ["git-annex", "mtr"]-	& Tor.isBridge-	& JoeySites.oldUseNetshellBox-	& Docker.configured-	& Docker.garbageCollected--- Orca is the main git-annex build box.-host hostname@"orca.kitenet.net" = standardSystem Unstable $ props-	& Hostname.set hostname-	& Apt.unattendedUpgrades-	& Docker.configured-	& Apt.buildDep ["git-annex"]-	& Docker.docked container hostname "amd64-git-annex-builder"-	& Docker.docked container hostname "i386-git-annex-builder"-	& Docker.docked container hostname "armel-git-annex-builder-companion"-	& Docker.docked container hostname "armel-git-annex-builder"-	& Docker.garbageCollected--- My laptop-host _hostname@"darkstar.kitenet.net" = Just $ props-	& Docker.configured+	-- Nothing super-important lives here.+	, standardSystem "clam.kitenet.net" Unstable+		& cleanCloudAtCost+		& Apt.unattendedUpgrades+		& Network.ipv6to4+		& Tor.isBridge+		& Docker.configured+		& cname "shell.olduse.net"+		& JoeySites.oldUseNetShellBox++		& cname "openid.kitenet.net"+		& Docker.docked hosts "openid-provider"+		 	`requires` Apt.installed ["ntp"]++		& cname "ancient.kitenet.net"+		& Docker.docked hosts "ancient-kitenet"++		& Docker.garbageCollected `period` Daily+		& Apt.installed ["git-annex", "mtr", "screen"] 	--- add more hosts here...---host "foo.example.com" =-host _ = Nothing+	-- Orca is the main git-annex build box.+	, standardSystem "orca.kitenet.net" Unstable+		& Hostname.sane+		& Apt.unattendedUpgrades+		& Docker.configured+		& Docker.docked hosts "amd64-git-annex-builder"+		& Docker.docked hosts "i386-git-annex-builder"+		! Docker.docked hosts "armel-git-annex-builder-companion"+		! Docker.docked hosts "armel-git-annex-builder"+		& Docker.garbageCollected `period` Daily+		& Apt.buildDep ["git-annex"] `period` Daily+	+	-- Important stuff that needs not too much memory or CPU.+  	, standardSystem "diatom.kitenet.net" Stable+		& Hostname.sane+		& Apt.unattendedUpgrades+		& Apt.serviceInstalledRunning "ntp"+		& Dns.zones myDnsSecondary+		& 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) --- | This is where Docker containers are set up. A container--- can vary by hostname where it's used, or be the same everywhere.-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)-container _host name-	| name == "webserver" = Just $ Docker.containerFrom-		(image $ System (Debian Unstable) "amd64")-		[ Docker.publish "8080:80"-		, Docker.volume "/var/www:/var/www"-		, Docker.inside $ props-			& serviceRunning "apache2"-				`requires` Apt.installed ["apache2"]-		]+	--------------------------------------------------------------------+	--  Docker Containers  ----------------------------------- \o/ -----+	--------------------------------------------------------------------++	-- Simple web server, publishing the outside host's /var/www+	, standardContainer "webserver" Stable "amd64"+		& Docker.publish "8080:80"+		& Docker.volume "/var/www:/var/www"+		& Apt.serviceInstalledRunning "apache2"++	-- My own openid provider. Uses php, so containerized for security+	-- and administrative sanity.+	, standardContainer "openid-provider" Stable "amd64"+		& Docker.publish "8081:80"+		& OpenId.providerFor ["joey", "liw"]+			"openid.kitenet.net:8081" 	+	, 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-annex autobuilder containers+	, gitAnnexBuilder "amd64" 15+	, gitAnnexBuilder "i386" 45 	-- armel builder has a companion container that run amd64 and 	-- runs the build first to get TH splices. They share a home 	-- directory, and need to have the same versions of all haskell 	-- libraries installed.-	| name == "armel-git-annex-builder-companion" = Just $ Docker.containerFrom+	, Docker.container "armel-git-annex-builder-companion" 		(image $ System (Debian Unstable) "amd64")-		[ Docker.volume GitAnnexBuilder.homedir-		]-	| name == "armel-git-annex-builder" = Just $ Docker.containerFrom+		& Docker.volume GitAnnexBuilder.homedir+		& Apt.unattendedUpgrades+	, Docker.container "armel-git-annex-builder" 		(image $ System (Debian Unstable) "armel")-		[ Docker.link (name ++ "-companion") "companion"-		, Docker.volumes_from (name ++ "-companion")-		, Docker.inside $ props---			& GitAnnexBuilder.builder "armel" "15 * * * *" True-		]-	-	| "-git-annex-builder" `isSuffixOf` name =-		let arch = takeWhile (/= '-') name-		in Just $ Docker.containerFrom-			(image $ System (Debian Unstable) arch)-			[ Docker.inside $ props & GitAnnexBuilder.builder arch "15 * * * *" True ]-	-	| otherwise = Nothing+		& Docker.link "armel-git-annex-builder-companion" "companion"+		& Docker.volumes_from "armel-git-annex-builder-companion"+--		& GitAnnexBuilder.builder "armel" "15 * * * *" True+		& Apt.unattendedUpgrades+	] +gitAnnexBuilder :: Architecture -> Int -> Host+gitAnnexBuilder arch buildminute = Docker.container (arch ++ "-git-annex-builder")+	(image $ System (Debian Unstable) arch)+	& GitAnnexBuilder.builder arch (show buildminute ++ " * * * *") True+	& Apt.unattendedUpgrades++-- This is my standard system setup.+standardSystem :: HostName -> DebianSuite -> Host+standardSystem hn suite = host hn+	& Apt.stdSourcesList suite `onChange` Apt.upgrade+	& Apt.installed ["etckeeper"]+	& Apt.installed ["ssh"]+	& GitHome.installedFor "root"+	& User.hasSomePassword "root"+	-- Harden the system, but only once root's authorized_keys+	-- is safely in place.+	& check (Ssh.hasAuthorizedKeys "root")+		(Ssh.passwordAuthentication False)+	& User.accountFor "joey"+	& User.hasSomePassword "joey"+	& Sudo.enabledFor "joey"+	& GitHome.installedFor "joey"+	& Apt.installed ["vim", "screen", "less"]+	& Cron.runPropellor "30 * * * *"+	-- I use postfix, or no MTA.+	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]+		`onChange` Apt.autoRemove++-- This is my standard container setup, featuring automatic upgrades.+standardContainer :: Docker.ContainerName -> DebianSuite -> Architecture -> Host+standardContainer name suite arch = Docker.container name (image system)+	& Apt.stdSourcesList suite+	& Apt.unattendedUpgrades+  where+	system = System (Debian suite) arch+ -- | Docker images I prefer to use. image :: System -> Docker.Image image (System (Debian Unstable) arch) = "joeyh/debian-unstable-" ++ arch+image (System (Debian Stable) arch) = "joeyh/debian-stable-" ++ arch image _ = "debian-stable-official" -- does not currently exist! --- This is my standard system setup-standardSystem :: DebianSuite -> [Property] -> Maybe [Property]-standardSystem suite customprops = Just $-	standardprops : customprops ++ endprops-  where-	standardprops = propertyList "standard system" $ props-		& Apt.stdSourcesList suite `onChange` Apt.upgrade-		& Apt.installed ["etckeeper"]-		& Apt.installed ["ssh"]-		& GitHome.installedFor "root"-		& User.hasSomePassword "root"-		-- Harden the system, but only once root's authorized_keys-		-- is safely in place.-		& check (Ssh.hasAuthorizedKeys "root")-			(Ssh.passwordAuthentication False)-		& User.accountFor "joey"-		& User.hasSomePassword "joey"-		& Sudo.enabledFor "joey"-		& GitHome.installedFor "joey"-		& Apt.installed ["vim", "screen", "less"]-		& Cron.runPropellor "30 * * * *"-		-- I use postfix, or no MTA.-		& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]-			`onChange` Apt.autoRemove-	-- May reboot, so comes last-	-- Currently not enable due to #726375 -	endprops = [] -- [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]- -- Clean up a system as installed by cloudatcost.com-cleanCloudAtCost :: HostName -> Property-cleanCloudAtCost hostname = propertyList "cloudatcost cleanup"-	[ Hostname.set hostname+cleanCloudAtCost :: Property+cleanCloudAtCost = propertyList "cloudatcost cleanup"+	[ Hostname.sane 	, Ssh.uniqueHostKeys 	, "worked around grub/lvm boot bug #743126" ==> 		"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"@@ -141,3 +185,18 @@ 		, User.nuked "user" User.YesReallyDeleteHome 		] 	]++myDnsSecondary :: [Dns.Zone]+myDnsSecondary =+	[ Dns.secondary "kitenet.net" master+	, Dns.secondary "joeyh.name" master+	, Dns.secondary "ikiwiki.info" master+	, Dns.secondary "olduse.net" master+	, Dns.secondary "branchable.com" branchablemaster+	]+  where+	master = ["80.68.85.49", "2001:41c8:125:49::10"] -- wren+	branchablemaster = ["66.228.46.55", "2600:3c03::f03c:91ff:fedf:c0e5"]++main :: IO ()+main = defaultMain hosts --, Docker.containerProperties container]

@@ -3,6 +3,7 @@  import Propellor import Propellor.CmdLine+import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network@@ -15,39 +16,32 @@ --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker -main :: IO ()-main = defaultMain [host, Docker.containerProperties container]---- | This is where the system's HostName, either as returned by uname--- or one specified on the command line, is converted into a list of--- Properties for that system.---+-- The hosts propellor knows about. -- Edit this to configure propellor!-host :: HostName -> Maybe [Property]-host hostname@"mybox.example.com" = Just $ props-	& Apt.stdSourcesList Unstable-		`onChange` Apt.upgrade-	& Apt.unattendedUpgrades-	& Apt.installed ["etckeeper"]-	& Apt.installed ["ssh"]-	& User.hasSomePassword "root"-	& Network.ipv6to4-	& File.dirExists "/var/www"-	& Docker.docked container hostname "webserver"-	& Docker.garbageCollected-	& Cron.runPropellor "30 * * * *"--- add more hosts here...---host "foo.example.com" =-host _ = Nothing+hosts :: [Host]+hosts =+	[ host "mybox.example.com"+		& Apt.stdSourcesList Unstable+			`onChange` Apt.upgrade+		& Apt.unattendedUpgrades+		& Apt.installed ["etckeeper"]+		& Apt.installed ["ssh"]+		& User.hasSomePassword "root"+		& Network.ipv6to4+		& File.dirExists "/var/www"+		& Docker.docked hosts "webserver"+		& Docker.garbageCollected `period` Daily+		& Cron.runPropellor "30 * * * *" --- | This is where Docker containers are set up. A container--- can vary by hostname where it's used, or be the same everywhere.-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)-container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"-	[ Docker.publish "80:80"-	, Docker.volume "/var/www:/var/www"-	, Docker.inside $ props-		& serviceRunning "apache2"-			`requires` Apt.installed ["apache2"]+	-- A generic webserver in a Docker container.+	, Docker.container "webserver" "joeyh/debian-unstable"+		& Docker.publish "80:80"+		& Docker.volume "/var/www:/var/www"+		& Apt.serviceInstalledRunning "apache2"++	-- add more hosts here...+	--, host "foo.example.com" = ... 	]-container _ _ = Nothing++main :: IO ()+main = defaultMain hosts

@@ -3,6 +3,7 @@  import Propellor import Propellor.CmdLine+import Propellor.Property.Scheduled import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network@@ -15,39 +16,32 @@ --import qualified Propellor.Property.Tor as Tor import qualified Propellor.Property.Docker as Docker -main :: IO ()-main = defaultMain [host, Docker.containerProperties container]---- | This is where the system's HostName, either as returned by uname--- or one specified on the command line, is converted into a list of--- Properties for that system.---+-- The hosts propellor knows about. -- Edit this to configure propellor!-host :: HostName -> Maybe [Property]-host hostname@"mybox.example.com" = Just $ props-	& Apt.stdSourcesList Unstable-		`onChange` Apt.upgrade-	& Apt.unattendedUpgrades-	& Apt.installed ["etckeeper"]-	& Apt.installed ["ssh"]-	& User.hasSomePassword "root"-	& Network.ipv6to4-	& File.dirExists "/var/www"-	& Docker.docked container hostname "webserver"-	& Docker.garbageCollected-	& Cron.runPropellor "30 * * * *"--- add more hosts here...---host "foo.example.com" =-host _ = Nothing+hosts :: [Host]+hosts =+	[ host "mybox.example.com"+		& Apt.stdSourcesList Unstable+			`onChange` Apt.upgrade+		& Apt.unattendedUpgrades+		& Apt.installed ["etckeeper"]+		& Apt.installed ["ssh"]+		& User.hasSomePassword "root"+		& Network.ipv6to4+		& File.dirExists "/var/www"+		& Docker.docked hosts "webserver"+		& Docker.garbageCollected `period` Daily+		& Cron.runPropellor "30 * * * *" --- | This is where Docker containers are set up. A container--- can vary by hostname where it's used, or be the same everywhere.-container :: HostName -> Docker.ContainerName -> Maybe (Docker.Container)-container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"-	[ Docker.publish "80:80"-	, Docker.volume "/var/www:/var/www"-	, Docker.inside $ props-		& serviceRunning "apache2"-			`requires` Apt.installed ["apache2"]+	-- A generic webserver in a Docker container.+	, Docker.container "webserver" "joeyh/debian-unstable"+		& Docker.publish "80:80"+		& Docker.volume "/var/www:/var/www"+		& Apt.serviceInstalledRunning "apache2"++	-- add more hosts here...+	--, host "foo.example.com" = ... 	]-container _ _ = Nothing++main :: IO ()+main = defaultMain hosts

@@ -1,3 +1,18 @@+propellor (0.3.0) unstable; urgency=medium++  * ipv6to4: Ensure interface is brought up automatically on boot.+  * Enabling unattended upgrades now ensures that cron is installed and+    running to perform them.+  * Properties can be scheduled to only be checked after a given time period.+  * Fix bootstrapping of dependencies.+  * Fix compilation on Debian stable.+  * Include security updates in sources.list for stable and testing.+  * Use ssh connection caching, especially when bootstrapping.+  * Properties now run in a Propellor monad, which provides access to+    attributes of the host.++ -- Joey Hess <joeyh@debian.org>  Fri, 11 Apr 2014 01:19:05 -0400+ propellor (0.2.3) unstable; urgency=medium    * docker: Fix laziness bug that caused running containers to be

@@ -11,6 +11,8 @@ 	libghc-unix-compat-dev, 	libghc-ansi-terminal-dev, 	libghc-ifelse-dev,+	libghc-mtl-dev,+	libghc-monadcatchio-transformers-dev, Maintainer: Joey Hess <joeyh@debian.org> Standards-Version: 3.9.5 Vcs-Git: git://git.kitenet.net/propellor@@ -28,6 +30,8 @@ 	libghc-unix-compat-dev, 	libghc-ansi-terminal-dev, 	libghc-ifelse-dev,+	libghc-mtl-dev,+	libghc-monadcatchio-transformers-dev, 	git, Description: property-based host configuration management in haskell  Propellor enures that the system it's run in satisfies a list of

@@ -1,5 +1,5 @@ Name: propellor-Version: 0.2.3+Version: 0.3.0 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -38,7 +38,8 @@   GHC-Options: -Wall   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async+   containers, network, async, time, QuickCheck, mtl,+   MonadCatchIO-transformers      if (! os(windows))     Build-Depends: unix@@ -48,7 +49,8 @@   GHC-Options: -Wall -threaded   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async+   containers, network, async, time, QuickCheck, mtl,+   MonadCatchIO-transformers    if (! os(windows))     Build-Depends: unix@@ -57,7 +59,8 @@   GHC-Options: -Wall   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,     IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,-   containers, network, async+   containers, network, async, time, QuickCheck, mtl,+   MonadCatchIO-transformers    if (! os(windows))     Build-Depends: unix@@ -69,10 +72,15 @@     Propellor.Property.Cmd     Propellor.Property.Hostname     Propellor.Property.Cron+    Propellor.Property.Dns     Propellor.Property.Docker     Propellor.Property.File+    Propellor.Property.Git     Propellor.Property.Network+    Propellor.Property.OpenId     Propellor.Property.Reboot+    Propellor.Property.Scheduled+    Propellor.Property.Service     Propellor.Property.Ssh     Propellor.Property.Sudo     Propellor.Property.Tor@@ -80,11 +88,14 @@     Propellor.Property.SiteSpecific.GitHome     Propellor.Property.SiteSpecific.JoeySites     Propellor.Property.SiteSpecific.GitAnnexBuilder+    Propellor.Attr     Propellor.Message     Propellor.PrivData     Propellor.Engine+    Propellor.Exception     Propellor.Types   Other-Modules:+    Propellor.Types.Attr     Propellor.CmdLine     Propellor.SimpleSh     Propellor.Property.Docker.Shim@@ -103,9 +114,11 @@     Utility.PosixFiles     Utility.Process     Utility.SafeCommand+    Utility.Scheduled     Utility.ThreadScheduler     Utility.Tmp     Utility.UserInfo+    Utility.QuickCheck  source-repository head   type: git