new more expressive config.hs WIP

Propellor.hs

@@ -2,8 +2,9 @@
 
 -- | Pulls in lots of useful modules for building and using Properties.
 -- 
--- Propellor enures that the system it's run in satisfies a list of
+-- When propellor runs on a Host, it ensures that its list of Properties
--- properties, taking action as necessary when a property is not yet met.
+-- is satisfied, taking action as necessary when a Property is not
+-- currently satisfied.
 --
 -- A simple propellor program example:
 --
@@ -13,15 +14,16 @@
 -- > import qualified Propellor.Property.Apt as Apt
 -- > 
 -- > main :: IO ()
--- > main = defaultMain getProperties
+-- > main = defaultMain hosts
 -- > 
--- > getProperties :: HostName -> Maybe [Property]
+-- > hosts :: [Host]
--- > getProperties "example.com" = Just
+-- > hosts =
--- >    [ Apt.installed ["mydaemon"]
+-- >   [ host "example.com"
--- >    , "/etc/mydaemon.conf" `File.containsLine` "secure=1"
+-- >     & Apt.installed ["mydaemon"]
--- >        `onChange` cmdProperty "service" ["mydaemon", "restart"]
+-- >     & "/etc/mydaemon.conf" `File.containsLine` "secure=1"
--- >    ]
+-- >       `onChange` cmdProperty "service" ["mydaemon", "restart"]
--- > getProperties _ = Nothing
+-- >     ! Apt.installed ["unwantedpackage"]
+-- >   ]
 --
 -- See config.hs for a more complete example, and clone Propellor's
 -- git repository for a deployable system using Propellor:
@@ -31,6 +33,7 @@ module Propellor (
 	  module Propellor.Types
 	, module Propellor.Property
 	, module Propellor.Property.Cmd
+	, module Propellor.Attr
 	, module Propellor.PrivData
 	, module Propellor.Engine
 	, module Propellor.Exception
@@ -47,6 +50,7 @@ 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

Propellor/Attr.hs

@@ -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)

Propellor/CmdLine.hs

@@ -55,8 +55,8 @@ processCmdLine = go =<< getArgs
 			else return $ Run s
 	go _ = usage
 
-defaultMain :: [HostName -> Maybe [Property]] -> IO ()
+defaultMain :: [Host] -> IO ()
-defaultMain getprops = do
+defaultMain hostlist = do
 	DockerShim.cleanEnv
 	checkDebugMode
 	cmdline <- processCmdLine
@@ -64,25 +64,26 @@ defaultMain getprops = do
 	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 $ \hostattr ps -> do
+	go _ (Chain hn) = withprops hn $ \attr ps -> do
-		r <- runPropellor hostattr $ ensureProperties ps
+		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 . const $ spin host
+	go False (Spin hn) = withprops hn $ const . const $ spin hn
-	go False (Run host) = ifM ((==) 0 <$> getRealUserID)
+	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyProcess $ withprops host mainProperties
+		( onlyProcess $ withprops hn mainProperties
-		, go True (Spin host)
+		, 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 hostattr) $
+	withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
-		headMaybe $ catMaybes $ map (\get -> get host) getprops
+	withprops hn a = maybe
-	  where
+		(unknownhost hn)
-		hostattr = mkHostAttr host
+		(\h -> a (hostAttr h) (hostProperties h))
+		(findHost hostlist hn)
 
 onlyProcess :: IO a -> IO a
 onlyProcess a = bracket lock unlock (const a)
@@ -166,16 +167,16 @@ getCurrentGitSha1 :: String -> IO String
 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"]
-	cacheparams <- toCommand <$> sshCachingParams host
+	cacheparams <- toCommand <$> sshCachingParams hn
-	go cacheparams url =<< gpgDecrypt (privDataFile host)
+	go cacheparams url =<< gpgDecrypt (privDataFile hn)
   where
 	go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
 		let finish = do
-			senddata toh (privDataFile host) privDataMarker privdata
+			senddata toh (privDataFile hn) privDataMarker privdata
 			hClose toh
 			
 			-- Display remaining output.
@@ -188,10 +189,10 @@ spin host = do
 			NeedGitClone -> do
 				hClose toh
 				hClose fromh
-				sendGitClone host url
+				sendGitClone hn url
 				go cacheparams url privdata
 	
-	user = "root@"++host
+	user = "root@"++hn
 
 	bootstrapcmd = shellWrap $ intercalate " ; "
 		[ "if [ ! -d " ++ localdir ++ " ]"
@@ -202,7 +203,7 @@ spin host = do
 		, "else " ++ intercalate " && "
 			[ "cd " ++ localdir
 			, "if ! test -x ./propellor; then make deps build; fi"
-			, "./propellor --boot " ++ host
+			, "./propellor --boot " ++ hn
 			]
 		, "fi"
 		]
@@ -218,18 +219,18 @@ spin host = do
 	
 	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 host
+	cacheparams <- sshCachingParams hn
 	withTmpFile "propellor.git" $ \tmp _ -> allM id
 		[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
-		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++host++":"++remotebundle)]
+		, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
-		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++host), Param $ unpackcmd branch]
+		, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
 		]
   where
 	remotebundle = "/usr/local/propellor.git"
@@ -277,15 +278,15 @@ fromMarked marker s
 	len = length marker
 	matches = filter (marker `isPrefixOf`) $ lines s
 
-boot :: HostAttr -> [Property] -> IO ()
+boot :: Attr -> [Property] -> IO ()
-boot hostattr ps = do
+boot attr ps = do
 	sendMarked stdout statusMarker $ show Ready
 	reply <- hGetContentsStrict stdin
 
 	makePrivDataDir
 	maybe noop (writeFileProtected privDataLocal) $
 		fromMarked privDataMarker reply
-	mainProperties hostattr ps
+	mainProperties attr ps
 
 addKey :: String -> IO ()
 addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
@@ -347,11 +348,11 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
 
 -- Parameters can be passed to both ssh and scp.
 sshCachingParams :: HostName -> IO [CommandParam]
-sshCachingParams hostname = do
+sshCachingParams hn = do
 	home <- myHomeDir
 	let cachedir = home </> ".ssh" </> "propellor"
 	createDirectoryIfMissing False cachedir
-	let socketfile = cachedir </> hostname ++ ".sock"
+	let socketfile = cachedir </> hn ++ ".sock"
 	return
 		[ Param "-o", Param ("ControlPath=" ++ socketfile)
 		, Params "-o ControlMaster=auto -o ControlPersist=yes"

Propellor/Engine.hs

@@ -12,12 +12,12 @@ import Propellor.Types
 import Propellor.Message
 import Propellor.Exception
 
-runPropellor :: HostAttr -> Propellor a -> IO a
+runPropellor :: Attr -> Propellor a -> IO a
-runPropellor hostattr a = runReaderT (runWithHostAttr a) hostattr
+runPropellor attr a = runReaderT (runWithAttr a) attr
 
-mainProperties :: HostAttr -> [Property] -> IO ()
+mainProperties :: Attr -> [Property] -> IO ()
-mainProperties hostattr ps = do
+mainProperties attr ps = do
-	r <- runPropellor hostattr $
+	r <- runPropellor attr $
 		ensureProperties [Property "overall" $ ensureProperties ps]
 	setTitle "propellor: done"
 	hFlush stdout

Propellor/PrivData.hs

@@ -12,6 +12,7 @@ import Control.Monad
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
+import Propellor.Attr
 import Propellor.Message
 import Utility.Monad
 import Utility.PartialPrelude

Propellor/Property.hs

@@ -9,6 +9,8 @@ import Control.Monad.IfElse
 import "mtl" Control.Monad.Reader
 
 import Propellor.Types
+import Propellor.Types.Attr
+import Propellor.Attr
 import Propellor.Engine
 import Utility.Monad
 
@@ -94,17 +96,46 @@ boolProperty desc a = Property desc $ ifM (liftIO a)
 revert :: RevertableProperty -> RevertableProperty
 revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 
--- | Starts a list of Properties
+-- | Starts accumulating the properties of a Host.
-props :: [Property]
+--
-props = []
+-- > host "example.com"
+-- > 	& someproperty
+-- > 	! oldproperty
+-- > 	& otherproperty
+host :: HostName -> Host
+host hn = Host [] (\_ -> newAttr hn)
+
+-- | Adds a property to a Host
+-- Can add Properties, RevertableProperties, and AttrProperties
+(&) :: IsProp p => Host -> p -> Host
+(Host ps as) & p = Host (ps ++ [toProp p]) (as . getAttr p)
 
--- | Adds a property to the list.
--- Can add both Properties and RevertableProperties.
-(&) :: IsProp p => [Property] -> p -> [Property]
-ps & p = ps ++ [toProp p]
 infixl 1 &
 
--- | Adds a property to the list in reverted form.
+-- | Adds a property to the Host in reverted form.
-(!) :: [Property] -> RevertableProperty -> [Property]
+(!) :: Host -> RevertableProperty -> Host
-ps ! p = ps ++ [toProp $ revert p]
+(Host ps as) ! p = Host (ps ++ [toProp q]) (as . getAttr q)
+  where
+	q = revert p
+
 infixl 1 !
+
+-- | Makes a propertyList of a set of properties, using the same syntax
+-- used by `host`.
+--
+-- > template "my template" $ props
+-- 	& someproperty
+-- 	! oldproperty
+--
+-- Note that none of the properties can define Attrs, because
+-- they will not propigate out to the host that this is added to.
+--
+-- Unfortunately, this is not currently enforced at the type level, so
+-- attempting to set an Attr in here will be run time error.
+template :: Desc -> Host -> Property
+template desc h@(Host ps _)
+	| hostAttr h == hostAttr props = propertyList desc ps
+	| otherwise = error $ desc ++ ": template contains Attr"
+
+props :: Host
+props = Host [] (\_ -> hostnameless)

Propellor/Property/Apt.hs

@@ -180,8 +180,8 @@ reConfigure package vals = reconfigure `requires` setselections
 	setselections = Property "preseed" $ makeChange $
 		withHandle StdinHandle createProcessSuccess
 			(proc "debconf-set-selections" []) $ \h -> do
-				forM_ vals $ \(template, tmpltype, value) ->
+				forM_ vals $ \(tmpl, tmpltype, value) ->
-					hPutStrLn h $ unwords [package, template, tmpltype, value]
+					hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
 				hClose h
 	reconfigure = cmdProperty "dpkg-reconfigure" ["-fnone", package]
 

Propellor/Property/Hostname.hs

@@ -13,14 +13,14 @@ sane :: Property
 sane = Property ("sane hostname") (ensureProperty . setTo =<< getHostName)
 
 setTo :: HostName -> Property
-setTo hostname = combineProperties desc go
+setTo hn = combineProperties desc go
-	`onChange` cmdProperty "hostname" [host]
+	`onChange` cmdProperty "hostname" [basehost]
   where
-	desc = "hostname " ++ hostname
+	desc = "hostname " ++ hn
-	(host, domain) = separate (== '.') hostname
+	(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
@@ -28,7 +28,7 @@ setTo hostname = combineProperties desc go
 		]
 	
 	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

Propellor/Property/SiteSpecific/JoeySites.hs

@@ -6,8 +6,8 @@ module Propellor.Property.SiteSpecific.JoeySites where
 import Propellor
 import qualified Propellor.Property.Apt as Apt
 
-oldUseNetshellBox :: Property
+oldUseNetShellBox :: Property
-oldUseNetshellBox = check (not <$> Apt.isInstalled "oldusenet") $
+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"

Propellor/Types.hs

@@ -1,7 +1,33 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
 
-module Propellor.Types where
+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
@@ -9,11 +35,26 @@ import System.Console.ANSI
 import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
 
-type HostName = String
+import Propellor.Types.Attr
-type GroupName = String
-type UserName = String
 
--- | The core data type of Propellor, this reprecents a property
+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
@@ -25,28 +66,8 @@ data Property = Property
 -- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
 
--- | Propellor's monad provides read-only access to attributes of the
+-- | A property that affects the Attr.
--- system.
+data AttrProperty = forall p. IsProp p => AttrProperty p (Attr -> Attr)
-newtype Propellor p = Propellor { runWithHostAttr :: ReaderT HostAttr IO p }
-	deriving
-		( Monad
-		, Functor
-		, Applicative
-		, MonadReader HostAttr 
-		, MonadIO
-		, MonadCatchIO
-		)
-
--- | The attributes of a system. For example, its hostname.
-newtype HostAttr = HostAttr
-	{ _hostname :: HostName
-	}
-
-mkHostAttr :: HostName -> HostAttr
-mkHostAttr = HostAttr 
-
-getHostName :: Propellor HostName
-getHostName = asks _hostname
 
 class IsProp p where
 	-- | Sets description.
@@ -55,6 +76,7 @@ class IsProp p where
 	-- | 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 }
@@ -64,6 +86,7 @@ instance IsProp Property where
 		case r of
 			FailedChange -> return FailedChange
 			_ -> propertySatisfy x
+	getAttr _ = id
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.
@@ -72,6 +95,13 @@ instance IsProp RevertableProperty where
 	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
 

Propellor/Types/Attr.hs

@@ -0,0 +1,16 @@
+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
+	}
+	deriving (Eq, Show)
+
+newAttr :: HostName -> Attr
+newAttr hn = Attr hn S.empty
+
+type HostName = String
+type Domain = String

TODO

@@ -3,8 +3,8 @@
   but only once despite many config changes being made to satisfy
   properties. onChange is a poor substitute.
 * Currently only Debian and derivatives are supported by most Properties.
-  One way to improve that would be to parameterize Properties with a
+  This could be improved by making the Distribution of the system part
-  Distribution witness.
+  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.

config-joey.hs

@@ -20,76 +20,68 @@ 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 ()
+hosts :: [Host]
-main = defaultMain [host, Docker.containerProperties container]
+hosts =
-
+	[ host "clam.kitenet.net"
--- | This is where the system's HostName, either as returned by uname
+		& cleanCloudAtCost
--- or one specified on the command line, is converted into a list of
+		& standardSystem Unstable
--- Properties for that system.
+		& Apt.unattendedUpgrades
---
+		& Network.ipv6to4
--- Edit this to configure propellor!
+		& Tor.isBridge
-host :: HostName -> Maybe [Property]
+		& Docker.configured
--- Clam is a tor bridge, and an olduse.net shellbox and other fun stuff.
+		& cname "shell.olduse.net"
-host "clam.kitenet.net" = Just $ withSystemd $ props
+			`requires` JoeySites.oldUseNetShellBox
-	& cleanCloudAtCost
+		& "openid.kitenet.net"
-	& standardSystem Unstable
+			`cnameFor` Docker.docked container
-	& Apt.unattendedUpgrades
+			`requires` Apt.installed ["ntp"]
-	& Network.ipv6to4
+		& "ancient.kitenet.net"
-	& Apt.installed ["git-annex", "mtr"]
+			`cnameFor` Docker.docked container
-	& Tor.isBridge
+		& Docker.garbageCollected `period` Daily
-	& JoeySites.oldUseNetshellBox
+		& Apt.installed ["git-annex", "mtr", "screen"]
-	& Docker.docked container "openid-provider"
+	-- Orca is the main git-annex build box.
-		`requires` Apt.installed ["ntp"]
+	, host "orca.kitenet.net"
-	& Docker.docked container "ancient-kitenet"
+		& standardSystem Unstable
-	& Docker.configured
+		& Hostname.sane
-	& Docker.garbageCollected `period` Daily
+		& Apt.unattendedUpgrades
--- Orca is the main git-annex build box.
+		& Docker.configured
-host "orca.kitenet.net" = Just $ props -- no systemd due to #726375
+		& Docker.docked container "amd64-git-annex-builder"
-	& standardSystem Unstable
+		& Docker.docked container "i386-git-annex-builder"
-	& Hostname.sane
+		! Docker.docked container "armel-git-annex-builder-companion"
-	& Apt.unattendedUpgrades
+		! Docker.docked container "armel-git-annex-builder"
-	& Docker.configured
+		& Docker.garbageCollected `period` Daily
-	& Apt.buildDep ["git-annex"] `period` Daily
+		& Apt.buildDep ["git-annex"] `period` Daily
-	& Docker.docked container "amd64-git-annex-builder"
+	-- Important stuff that needs not too much memory or CPU.
-	& Docker.docked container "i386-git-annex-builder"
+  	, host "diatom.kitenet.net"
-	! Docker.docked container "armel-git-annex-builder-companion"
+		& standardSystem Stable
-	! Docker.docked container "armel-git-annex-builder"
+		& Hostname.sane
-	& Docker.garbageCollected `period` Daily
+		& Apt.unattendedUpgrades
--- Diatom is my downloads and git repos server, and secondary dns server.
+		& Apt.serviceInstalledRunning "ntp"
-host "diatom.kitenet.net" = Just $ props
+		& Dns.zones myDnsSecondary
-	& standardSystem Stable
+		& Apt.serviceInstalledRunning "apache2"
-	& Hostname.sane
+		& Apt.installed ["git", "git-annex", "rsync"]
-	& Apt.unattendedUpgrades
+		& Apt.buildDep ["git-annex"] `period` Daily
-	& Apt.serviceInstalledRunning "ntp"
+		& Git.daemonRunning "/srv/git"
-	& Dns.zones myDnsSecondary
+		& File.ownerGroup "/srv/git" "joey" "joey"
-	& Apt.serviceInstalledRunning "apache2"
+		-- git repos restore (how?)
-	& Apt.installed ["git", "git-annex", "rsync"]
+		-- family annex needs family members to have accounts,
-	& Apt.buildDep ["git-annex"] `period` Daily
+		--     ssh host key etc.. finesse?
-	& Git.daemonRunning "/srv/git"
+		--   (also should upgrade git-annex-shell for it..)
-	& File.ownerGroup "/srv/git" "joey" "joey"
+		-- kgb installation and setup
-	-- git repos restore (how?)
+		-- ssh keys for branchable and github repo hooks
-	-- family annex needs family members to have accounts,
+		-- gitweb
-	--     ssh host key etc.. finesse?
+		-- downloads.kitenet.net setup (including ssh key to turtle)
-	--   (also should upgrade git-annex-shell for it..)
+	-- My laptop
-	-- kgb installation and setup
+	, host "darkstar.kitenet.net"
-	-- ssh keys for branchable and github repo hooks
+		& Docker.configured
-	-- gitweb
+		& Apt.buildDep ["git-annex"] `period` Daily
-	-- downloads.kitenet.net setup (including ssh key to turtle)
+	]
--- My laptop
-host "darkstar.kitenet.net" = Just $ props
-	& Docker.configured
-	& Apt.buildDep ["git-annex"] `period` Daily
-	
--- add more hosts here...
---host "foo.example.com" =
-host _ = Nothing
 
 -- | 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
+{-
 	-- Simple web server, publishing the outside host's /var/www
 	| name == "webserver" = Just $ standardContainer Stable "amd64"
 		[ Docker.publish "8080:80"
@@ -148,7 +140,7 @@ container _parenthost name
 				& GitAnnexBuilder.builder arch "15 * * * *" True
 				& Apt.unattendedUpgrades
 			]
-	
+-}
 	| otherwise = Nothing
 
 -- | Docker images I prefer to use.
@@ -159,7 +151,7 @@ image _ = "debian-stable-official" -- does not currently exist!
 
 -- This is my standard system setup
 standardSystem :: DebianSuite -> Property
-standardSystem suite = propertyList "standard system" $ props
+standardSystem suite = template "standard system" $ props
 	& Apt.stdSourcesList suite `onChange` Apt.upgrade
 	& Apt.installed ["etckeeper"]
 	& Apt.installed ["ssh"]
@@ -179,9 +171,7 @@ standardSystem suite = propertyList "standard system" $ props
 	& Apt.removed ["exim4", "exim4-daemon-light", "exim4-config", "exim4-base"]
 		`onChange` Apt.autoRemove
 
-withSystemd :: [Property] -> [Property]
+{-
-withSystemd ps = ps ++ [Apt.installed ["systemd-sysv"] `onChange` Reboot.now]
-
 -- This is my standard container setup, featuring automatic upgrades.
 standardContainer :: DebianSuite -> Architecture -> [Docker.Containerized Property] -> Docker.Container
 standardContainer suite arch ps = Docker.containerFrom
@@ -190,6 +180,7 @@ standardContainer suite arch ps = Docker.containerFrom
 		& Apt.stdSourcesList suite
 		& Apt.unattendedUpgrades
 	] ++ ps
+-}
 
 -- Clean up a system as installed by cloudatcost.com
 cleanCloudAtCost :: Property
@@ -218,3 +209,6 @@ myDnsSecondary =
   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]

propellor.cabal

@@ -88,12 +88,14 @@ Library
     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