From a52a2a89dfe92d7bed4a6446101657a288fd3bae Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 8 Apr 2014 19:31:03 -0400
Subject: serviceInstalledRunning

---
 config-simple.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

(limited to 'config-simple.hs')

diff --git a/config-simple.hs b/config-simple.hs
index d5015ef3..5e43b467 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -47,7 +47,6 @@ 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"]
+		& Apt.serviceInstalledRunning "apache2"
 	]
 container _ _ = Nothing
-- 
cgit v1.3-2-g0d8e


From 064cdd8fc575e5a16fa20bf382387560e9e4c580 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Wed, 9 Apr 2014 00:54:27 -0400
Subject: propellor spin

---
 Propellor/PrivData.hs           |   1 +
 Propellor/Property/Scheduled.hs |  58 +++++++
 TODO                            |   2 -
 Utility/QuickCheck.hs           |  52 ++++++
 Utility/Scheduled.hs            | 358 ++++++++++++++++++++++++++++++++++++++++
 config-joey.hs                  |   8 +-
 config-simple.hs                |   3 +-
 debian/changelog                |   1 +
 propellor.cabal                 |  10 +-
 9 files changed, 484 insertions(+), 9 deletions(-)
 create mode 100644 Propellor/Property/Scheduled.hs
 create mode 100644 Utility/QuickCheck.hs
 create mode 100644 Utility/Scheduled.hs

(limited to 'config-simple.hs')

diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
index e768ae9e..2897d425 100644
--- a/Propellor/PrivData.hs
+++ b/Propellor/PrivData.hs
@@ -23,6 +23,7 @@ withPrivData field a = maybe missing a =<< getPrivData field
   where
 	missing = do
 		warningMessage $ "Missing privdata " ++ show field
+		putStrLn $ "Fix this by running: propellor --set $hostname '" ++ show field ++ "'"
 		return FailedChange
 
 getPrivData :: PrivDataField -> IO (Maybe String)
diff --git a/Propellor/Property/Scheduled.hs b/Propellor/Property/Scheduled.hs
new file mode 100644
index 00000000..42ff0068
--- /dev/null
+++ b/Propellor/Property/Scheduled.hs
@@ -0,0 +1,58 @@
+module Propellor.Property.Scheduled
+	( period
+	, 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 <- getLastChecked (propertyDesc prop)
+	nexttime <- fmap startTime <$> nextTime schedule lasttime
+	t <- localNow
+	if Just t >= nexttime
+		then do
+			r <- ensureProperty prop
+			setLastChecked t (propertyDesc prop)
+			return r
+		else noChange
+  where
+	schedule = Schedule recurrance AnyTime
+	desc = propertyDesc prop ++ " (period " ++ show recurrance ++ ")"
+
+lastCheckedFile :: FilePath
+lastCheckedFile = localdir </> ".lastchecked"
+
+getLastChecked :: Desc -> IO (Maybe LocalTime)
+getLastChecked desc = M.lookup desc <$> readLastChecked
+
+localNow :: IO LocalTime
+localNow = do
+	now <- getCurrentTime
+	tz <- getTimeZone now
+	return $ utcToLocalTime tz now
+
+setLastChecked :: LocalTime -> Desc -> IO ()
+setLastChecked time desc = do
+	m <- readLastChecked
+	writeLastChecked (M.insert desc time m)
+
+readLastChecked :: IO (M.Map Desc LocalTime)
+readLastChecked = fromMaybe M.empty <$> catchDefaultIO Nothing go
+  where
+	go = readish <$> readFile lastCheckedFile
+
+writeLastChecked :: M.Map Desc LocalTime -> IO ()
+writeLastChecked = writeFile lastCheckedFile . show
diff --git a/TODO b/TODO
index 40bbd01e..a1f1c689 100644
--- a/TODO
+++ b/TODO
@@ -12,8 +12,6 @@
   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
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
new file mode 100644
index 00000000..7f7234c7
--- /dev/null
+++ b/Utility/QuickCheck.hs
@@ -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)
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
new file mode 100644
index 00000000..6b0609d8
--- /dev/null
+++ b/Utility/Scheduled.hs
@@ -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)
+	-- ^ Days, Weeks, or Months of the year evenly divisible by a number.
+	-- (Divisible Year is years evenly divisible by a number.)
+	| Divisible Int Recurrance
+  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
diff --git a/config-joey.hs b/config-joey.hs
index 3b796ce7..6c4507d6 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -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
@@ -38,21 +39,22 @@ host hostname@"clam.kitenet.net" = standardSystem Unstable $ props
 	& JoeySites.oldUseNetshellBox
 	& Docker.docked container hostname "openid-provider"
 	& Docker.configured
-	& Docker.garbageCollected
+	& Docker.garbageCollected `period` Daily
 -- 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"]
+	& Apt.buildDep ["git-annex"] `period` Daily
 	& 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
+	& Docker.garbageCollected `period` Daily
 -- My laptop
 host _hostname@"darkstar.kitenet.net" = Just $ props
 	& Docker.configured
+	& Apt.buildDep ["git-annex"] `period` Daily
 	
 -- add more hosts here...
 --host "foo.example.com" =
diff --git a/config-simple.hs b/config-simple.hs
index 5e43b467..6784f76c 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -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
@@ -34,7 +35,7 @@ host hostname@"mybox.example.com" = Just $ props
 	& Network.ipv6to4
 	& File.dirExists "/var/www"
 	& Docker.docked container hostname "webserver"
-	& Docker.garbageCollected
+	& Docker.garbageCollected `period` Daily
 	& Cron.runPropellor "30 * * * *"
 -- add more hosts here...
 --host "foo.example.com" =
diff --git a/debian/changelog b/debian/changelog
index 4b04fb30..d83b6ad8 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -3,6 +3,7 @@ propellor (0.2.4) UNRELEASED; 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.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 08 Apr 2014 18:07:12 -0400
 
diff --git a/propellor.cabal b/propellor.cabal
index 0869ef58..c3f4f4c0 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -38,7 +38,7 @@ Executable propellor
   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
   
   if (! os(windows))
     Build-Depends: unix
@@ -48,7 +48,7 @@ Executable config
   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
 
   if (! os(windows))
     Build-Depends: unix
@@ -57,7 +57,7 @@ Library
   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
 
   if (! os(windows))
     Build-Depends: unix
@@ -73,6 +73,8 @@ Library
     Propellor.Property.File
     Propellor.Property.Network
     Propellor.Property.Reboot
+    Propellor.Property.Scheduled
+    Propellor.Property.Service
     Propellor.Property.Ssh
     Propellor.Property.Sudo
     Propellor.Property.Tor
@@ -103,9 +105,11 @@ Library
     Utility.PosixFiles
     Utility.Process
     Utility.SafeCommand
+    Utility.Scheduled
     Utility.ThreadScheduler
     Utility.Tmp
     Utility.UserInfo
+    Utility.QuickCheck
 
 source-repository head
   type: git
-- 
cgit v1.3-2-g0d8e


From 2372d6a3f8193145662e393aa61b585d8bafd32d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 10 Apr 2014 17:46:03 -0400
Subject: use HostAttr to simplify config file

---
 Propellor/Property/Docker.hs   | 36 ++++++++++++++++++++----------------
 Propellor/Property/Hostname.hs | 13 ++++++++-----
 Propellor/Types.hs             |  2 +-
 config-joey.hs                 | 32 ++++++++++++++++----------------
 config-simple.hs               |  4 ++--
 5 files changed, 47 insertions(+), 40 deletions(-)

(limited to 'config-simple.hs')

diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index 1df34251..3828535c 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -40,36 +40,40 @@ installed = Apt.installed ["docker.io"]
 -- removed.
 docked
 	:: (HostName -> ContainerName -> Maybe (Container))
-	-> HostName
 	-> 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 findc 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 findc hn cn $ a cid]
+
+	setup cid (Container image containerprops) =
+		provisionContainer cid
+			`requires`
+		runningContainer cid image containerprops
+			`requires`
+		installed
+
+	teardown cid (Container image _) =
+		combineProperties ("undocked " ++ fromContainerId cid)
+			[ stoppedContainer cid
 			, Property ("cleaned up " ++ fromContainerId cid) $
 				liftIO $ report <$> mapM id
 					[ removeContainer cid
 					, removeImage image
 					]
 			]
-		in RevertableProperty setup teardown
-  where
-  	cid = ContainerId hn cn
 
 findContainer
 	:: (HostName -> ContainerName -> Maybe (Container))
 	-> HostName
 	-> ContainerName
-	-> (Container -> RevertableProperty)
-	-> RevertableProperty
+	-> (Container -> Property)
+	-> Property
 findContainer findc hn cn mk = case findc hn cn of
-	Nothing -> RevertableProperty cantfind cantfind
+	Nothing -> cantfind
 	Just container -> mk container
   where
   	cid = ContainerId hn cn
diff --git a/Propellor/Property/Hostname.hs b/Propellor/Property/Hostname.hs
index 26635374..0708b3ff 100644
--- a/Propellor/Property/Hostname.hs
+++ b/Propellor/Property/Hostname.hs
@@ -3,14 +3,17 @@ module Propellor.Property.Hostname where
 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
+sane :: Property
+sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
+
+setTo :: HostName -> Property
+setTo hostname = combineProperties desc go
 	`onChange` cmdProperty "hostname" [host]
   where
 	desc = "hostname " ++ hostname
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index b1632923..6a1c888a 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -27,7 +27,7 @@ data RevertableProperty = RevertableProperty Property Property
 
 -- | Propellor's monad provides read-only access to attributes of the
 -- system.
-newtype Propellor a = Propellor { runWithHostAttr :: ReaderT HostAttr IO a }
+newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p }
 	deriving
 		( Monad
 		, Functor
diff --git a/config-joey.hs b/config-joey.hs
index 2c6374c9..d1a33230 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -32,35 +32,35 @@ main = defaultMain [host, Docker.containerProperties container]
 -- 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" = Just $ withSystemd $ props
-	& cleanCloudAtCost hostname
+host "clam.kitenet.net" = Just $ withSystemd $ props
+	& cleanCloudAtCost
 	& standardSystem Unstable
 	& Apt.unattendedUpgrades
 	& Network.ipv6to4
 	& Apt.installed ["git-annex", "mtr"]
 	& Tor.isBridge
 	& JoeySites.oldUseNetshellBox
-	& Docker.docked container hostname "openid-provider"
+	& Docker.docked container "openid-provider"
 		`requires` Apt.installed ["ntp"]
-	& Docker.docked container hostname "ancient-kitenet"
+	& Docker.docked container "ancient-kitenet"
 	& Docker.configured
 	& Docker.garbageCollected `period` Daily
 -- Orca is the main git-annex build box.
-host hostname@"orca.kitenet.net" = Just $ props -- no systemd due to #726375
+host "orca.kitenet.net" = Just $ props -- no systemd due to #726375
 	& standardSystem Unstable
-	& Hostname.set hostname
+	& Hostname.sane
 	& Apt.unattendedUpgrades
 	& Docker.configured
 	& Apt.buildDep ["git-annex"] `period` Daily
-	& 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.docked container "amd64-git-annex-builder"
+	& Docker.docked container "i386-git-annex-builder"
+	! Docker.docked container "armel-git-annex-builder-companion"
+	! Docker.docked container "armel-git-annex-builder"
 	& Docker.garbageCollected `period` Daily
 -- Diatom is my downloads and git repos server, and secondary dns server.
-host hostname@"diatom.kitenet.net" = Just $ props
+host "diatom.kitenet.net" = Just $ props
 	& standardSystem Stable
-	& Hostname.set hostname
+	& Hostname.sane
 	& Apt.unattendedUpgrades
 	& Apt.serviceInstalledRunning "ntp"
 	& Dns.zones myDnsSecondary
@@ -78,7 +78,7 @@ host hostname@"diatom.kitenet.net" = Just $ props
 	-- gitweb
 	-- downloads.kitenet.net setup (including ssh key to turtle)
 -- My laptop
-host _hostname@"darkstar.kitenet.net" = Just $ props
+host "darkstar.kitenet.net" = Just $ props
 	& Docker.configured
 	& Apt.buildDep ["git-annex"] `period` Daily
 	
@@ -192,9 +192,9 @@ standardContainer suite arch ps = Docker.containerFrom
 	] ++ ps
 
 -- 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"
diff --git a/config-simple.hs b/config-simple.hs
index 6784f76c..8011e97e 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -25,7 +25,7 @@ main = defaultMain [host, Docker.containerProperties container]
 --
 -- Edit this to configure propellor!
 host :: HostName -> Maybe [Property]
-host hostname@"mybox.example.com" = Just $ props
+host "mybox.example.com" = Just $ props
 	& Apt.stdSourcesList Unstable
 		`onChange` Apt.upgrade
 	& Apt.unattendedUpgrades
@@ -34,7 +34,7 @@ host hostname@"mybox.example.com" = Just $ props
 	& User.hasSomePassword "root"
 	& Network.ipv6to4
 	& File.dirExists "/var/www"
-	& Docker.docked container hostname "webserver"
+	& Docker.docked container "webserver"
 	& Docker.garbageCollected `period` Daily
 	& Cron.runPropellor "30 * * * *"
 -- add more hosts here...
-- 
cgit v1.3-2-g0d8e


From 839e60bbcedf99efb7ec7fc8330585006ea1f222 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 10 Apr 2014 23:20:12 -0400
Subject: propellor spin

---
 Propellor/Property/Docker.hs | 160 +++++++++++++++++++------------------------
 Propellor/Types/Attr.hs      |  16 ++++-
 config-joey.hs               | 157 ++++++++++++++++++++----------------------
 config-simple.hs             |  56 +++++++--------
 4 files changed, 182 insertions(+), 207 deletions(-)

(limited to 'config-simple.hs')

diff --git a/Propellor/Property/Docker.hs b/Propellor/Property/Docker.hs
index 3828535c..edf12c2e 100644
--- a/Propellor/Property/Docker.hs
+++ b/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
 
 -- | Docker support for propellor
 --
@@ -9,6 +9,7 @@ module Propellor.Property.Docker where
 
 import Propellor
 import Propellor.SimpleSh
+import Propellor.Types.Attr
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Docker.Shim as Shim
@@ -32,6 +33,25 @@ configured = Property "docker configured" go `requires` installed
 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,24 +59,24 @@ installed = Apt.installed ["docker.io"]
 -- Reverting this property ensures that the container is stopped and
 -- removed.
 docked
-	:: (HostName -> ContainerName -> Maybe (Container))
+	:: [Host]
 	-> ContainerName
 	-> RevertableProperty
-docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown)
+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 findc hn cn $ a cid]
+		ensureProperties [findContainer hosts cid cn $ a cid]
 
-	setup cid (Container image containerprops) =
+	setup cid (Container image runparams) =
 		provisionContainer cid
 			`requires`
-		runningContainer cid image containerprops
+		runningContainer cid image runparams
 			`requires`
 		installed
 
-	teardown cid (Container image _) =
+	teardown cid (Container image _runparams) =
 		combineProperties ("undocked " ++ fromContainerId cid)
 			[ stoppedContainer cid
 			, Property ("cleaned up " ++ fromContainerId cid) $
@@ -67,20 +87,33 @@ docked findc cn = RevertableProperty (go "docked" setup) (go "undocked" teardown
 			]
 
 findContainer
-	:: (HostName -> ContainerName -> Maybe (Container))
-	-> HostName
+	:: [Host]
+	-> ContainerId
 	-> ContainerName
 	-> (Container -> Property)
 	-> Property
-findContainer findc hn cn mk = case findc hn cn of
+findContainer hosts cid cn mk = case findHost hosts (cn2hn cn) of
 	Nothing -> cantfind
-	Just container -> mk container
+	Just h -> maybe cantfind mk (mkContainer cid h)
   where
-  	cid = ContainerId hn cn
-	cantfind = containerDesc (ContainerId hn cn) $ Property "" $ do
-		liftIO $ 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
@@ -98,30 +131,7 @@ garbageCollected = propertyList "docker garbage collected"
 	gcimages = Property "docker images garbage collected" $ do
 		liftIO $ 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]
-
-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
@@ -129,62 +139,50 @@ type RunParam = String
 -- | 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
 
@@ -203,16 +201,6 @@ data ContainerId = ContainerId HostName ContainerName
 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
 
@@ -233,16 +221,13 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix
 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
+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
@@ -275,14 +260,6 @@ runningContainer cid@(ContainerId hn cn) image containerprops = containerDesc ci
 	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
 		liftIO $ do
 			clearProvisionedFlag cid
@@ -425,17 +402,18 @@ listContainers status =
 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
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
index 20e5e631..70161725 100644
--- a/Propellor/Types/Attr.hs
+++ b/Propellor/Types/Attr.hs
@@ -6,11 +6,23 @@ import qualified Data.Set as S
 data Attr = Attr
 	{ _hostname :: HostName
 	, _cnames :: S.Set Domain
+
+	, _dockerImage :: Maybe String
+	, _dockerRunParams :: [HostName -> String]
 	}
-	deriving (Eq, Show)
+
+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
+		]
 
 newAttr :: HostName -> Attr
-newAttr hn = Attr hn S.empty
+newAttr hn = Attr hn S.empty Nothing []
 
 type HostName = String
 type Domain = String
diff --git a/config-joey.hs b/config-joey.hs
index 92aa9093..093ed8a2 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -11,7 +11,7 @@ import qualified Propellor.Property.Cron as Cron
 import qualified Propellor.Property.Sudo as Sudo
 import qualified Propellor.Property.User as User
 import qualified Propellor.Property.Hostname as Hostname
-import qualified Propellor.Property.Reboot as Reboot
+--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
@@ -23,7 +23,13 @@ import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
 
 hosts :: [Host]
 hosts =
-	[ host "clam.kitenet.net"
+	-- My laptop
+	[ host "darkstar.kitenet.net"
+		& Docker.configured
+		& Apt.buildDep ["git-annex"] `period` Daily
+
+	-- Nothing super-important lives here.
+	, host "clam.kitenet.net"
 		& cleanCloudAtCost
 		& standardSystem Unstable
 		& Apt.unattendedUpgrades
@@ -31,26 +37,31 @@ hosts =
 		& Tor.isBridge
 		& Docker.configured
 		& cname "shell.olduse.net"
-			`requires` JoeySites.oldUseNetShellBox
-		& "openid.kitenet.net"
-			`cnameFor` Docker.docked container
+		& JoeySites.oldUseNetShellBox
+
+		& cname "openid.kitenet.net"
+		& Docker.docked hosts "openid-provider"
 			`requires` Apt.installed ["ntp"]
-		& "ancient.kitenet.net"
-			`cnameFor` Docker.docked container
+
+		& cname "ancient.kitenet.net"
+		& Docker.docked hosts "ancient-kitenet"
+
 		& Docker.garbageCollected `period` Daily
 		& Apt.installed ["git-annex", "mtr", "screen"]
+	
 	-- Orca is the main git-annex build box.
 	, host "orca.kitenet.net"
 		& standardSystem Unstable
 		& Hostname.sane
 		& Apt.unattendedUpgrades
 		& Docker.configured
-		& Docker.docked container "amd64-git-annex-builder"
-		& Docker.docked container "i386-git-annex-builder"
-		! Docker.docked container "armel-git-annex-builder-companion"
-		! Docker.docked container "armel-git-annex-builder"
+		& 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.
   	, host "diatom.kitenet.net"
 		& standardSystem Stable
@@ -71,83 +82,60 @@ hosts =
 		-- ssh keys for branchable and github repo hooks
 		-- gitweb
 		-- downloads.kitenet.net setup (including ssh key to turtle)
-	-- My laptop
-	, host "darkstar.kitenet.net"
-		& Docker.configured
-		& Apt.buildDep ["git-annex"] `period` Daily
-	]
 
--- | 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 _parenthost name
-{-
+	--------------------------------------------------------------------
+	--  Docker Containers  ----------------------------------- \o/ -----
+	--------------------------------------------------------------------
+
 	-- Simple web server, publishing the outside host's /var/www
-	| name == "webserver" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "8080:80"
-		, Docker.volume "/var/www:/var/www"
-		, Docker.inside $ props
-			& Apt.serviceInstalledRunning "apache2"
-		]
+	, 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.
-	| name == "openid-provider" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "8081:80"
-		, Docker.inside $ props
-			& OpenId.providerFor ["joey", "liw"]
-				"openid.kitenet.net:8081"
-		]
+	, standardContainer "openid-provider" Stable "amd64"
+		& Docker.publish "8081:80"
+		& OpenId.providerFor ["joey", "liw"]
+			"openid.kitenet.net:8081"
 	
-	| name == "ancient-kitenet" = Just $ standardContainer Stable "amd64"
-		[ Docker.publish "1994:80"
-		, Docker.inside $ props
-			& 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"
-		]
+	, 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
-		, Docker.inside $ props
-			& Apt.unattendedUpgrades
-		]
-	| 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
-			& Apt.unattendedUpgrades
-		]
-	
-	| "-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
-				& Apt.unattendedUpgrades
-			]
--}
-	| 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
+	]
 
--- | 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!
+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 :: DebianSuite -> Property
@@ -171,16 +159,19 @@ standardSystem suite = template "standard system" $ props
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove
 
-{-
 -- This is my standard container setup, featuring automatic upgrades.
-standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container
-standardContainer suite arch ps = Docker.containerFrom
-	(image $ System (Debian suite) arch) $
-	[ Docker.inside $ props
-		& Apt.stdSourcesList suite
-		& Apt.unattendedUpgrades
-	] ++ ps
--}
+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!
 
 -- Clean up a system as installed by cloudatcost.com
 cleanCloudAtCost :: Property
diff --git a/config-simple.hs b/config-simple.hs
index 8011e97e..23a760c8 100644
--- a/config-simple.hs
+++ b/config-simple.hs
@@ -16,38 +16,32 @@ import qualified Propellor.Property.User as User
 --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 "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 "webserver"
-	& Docker.garbageCollected `period` Daily
-	& 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
+	-- 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
-- 
cgit v1.3-2-g0d8e