various improvements

Propellor/Property/Apt.hs

@@ -16,16 +16,14 @@ sourcesList = "/etc/apt/sources.list"
 type Url = String
 type Section = String
 
-data Suite = Stable | Testing | Unstable | Experimental
-	deriving Show
-
-showSuite :: Suite -> String
+showSuite :: DebianSuite -> String
 showSuite Stable = "stable"
 showSuite Testing = "testing"
 showSuite Unstable = "unstable"
 showSuite Experimental = "experimental"
+showSuite (DebianRelease r) = r
 
-debLine :: Suite -> Url -> [Section] -> Line
+debLine :: DebianSuite -> Url -> [Section] -> Line
 debLine suite mirror sections = unwords $
 	["deb", mirror, showSuite suite] ++ sections
 
@@ -37,14 +35,14 @@ srcLine l = case words l of
 stdSections :: [Section]
 stdSections = ["main", "contrib", "non-free"]
 
-debCdn :: Suite -> [Line]
+debCdn :: DebianSuite -> [Line]
 debCdn suite = [l, srcLine l]
   where
 	l = debLine suite "http://cdn.debian.net/debian" stdSections
 
 {- | Makes sources.list have a standard content using the mirror CDN,
- - with a particular Suite. -}
-stdSourcesList :: Suite -> Property
+ - with a particular DebianSuite. -}
+stdSourcesList :: DebianSuite -> Property
 stdSourcesList suite = setSourcesList (debCdn suite)
 	`describe` ("standard sources.list for " ++ show suite)
 
@@ -81,6 +79,12 @@ removed ps = check (or <$> isInstalled' ps) go
   where
 	go = runApt $ ["-y", "remove"] ++ ps
 
+buildDep :: [Package] -> Property
+buildDep ps = check (isInstallable ps) go
+	`describe` (unwords $ "apt build-dep":ps)
+  where
+	go = runApt $ ["-y", "build-dep"] ++ ps
+
 isInstallable :: [Package] -> IO Bool
 isInstallable ps = do
 	l <- isInstalled' ps

Propellor/Property/Cmd.hs

@@ -2,6 +2,7 @@ module Propellor.Property.Cmd (
 	cmdProperty,
 	cmdProperty',
 	scriptProperty,
+	userScriptProperty,
 	serviceRunning,
 ) where
 
@@ -39,6 +40,13 @@ scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
   where
 	shellcmd = intercalate " ; " ("set -e" : script)
 
+-- | A property that can satisfied by running a series of shell commands,
+-- as user (staring in their home directory).
+userScriptProperty :: UserName -> [String] -> Property
+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

Propellor/Property/Docker.hs

@@ -99,12 +99,12 @@ containerDesc cid p = p `describe` desc
 -- | 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.
-hasContainer
-	:: HostName
+docked
+	:: (HostName -> ContainerName -> Maybe (Container))
+	-> HostName
 	-> ContainerName
-	-> (HostName -> ContainerName -> Maybe (Container))
 	-> Property
-hasContainer hn cn findcontainer = 
+docked findcontainer hn cn = 
 	case findcontainer hn cn of
 		Nothing -> containerDesc cid $ Property "" $ do
 			warningMessage $ "missing definition for docker container \"" ++ fromContainerId cid

Propellor/Property/SiteSpecific/GitAnnexBuilder.hs

@@ -0,0 +1,45 @@
+module Propellor.Property.SiteSpecific.GitAnnexBuilder where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.User as User
+import Propellor.Property.Cron (CronTimes)
+
+type Arch = String
+
+builduser :: UserName
+builduser = "builder"
+
+builddir :: FilePath
+builddir = "gitbuilder"
+
+builder :: Arch -> CronTimes -> Property
+builder arch crontimes = combineProperties
+	[ Apt.buildDep ["git-annex"]
+	, Apt.installed ["git", "rsync", "liblockfile-simple-perl"]
+	, serviceRunning "cron" `requires` Apt.installed ["cron"]
+	, User.accountFor builduser
+	, check (not <$> hasbuilddir) $ userScriptProperty builduser
+		[ "cabal update"
+		, "git clone https://github.com/joeyh/gitbuilder/"
+		, "cd gitbuilder && git checkout " ++ arch
+		, "echo '"++crontimes++" cd gitbuilder/autobuild' | crontab -"
+		]
+		`describe` "gitbuilder setup"
+	-- The builduser account does not have a password set,
+	-- instead use the password privdata to hold the rsync server
+	-- password used to upload the built image.
+	, Property "rsync password" $ do
+		d <- homedir
+		let f = d </> "rsyncpassword"
+		withPrivData (Password builduser) $ \p -> do
+			oldp <- catchDefaultIO "" $ readFileStrict f
+			if p /= oldp
+				then makeChange $ writeFile f p
+				else noChange
+	]
+  where
+  	homedir = fromMaybe ("/home/" ++ builduser) <$> User.homedir builduser
+	hasbuilddir = do
+		d <- homedir
+		doesDirectoryExist (d </> builddir)

Propellor/Property/SiteSpecific/GitHome.hs

@@ -1,11 +1,11 @@
-module Propellor.Property.GitHome where
+module Propellor.Property.SiteSpecific.GitHome where
 
 import Propellor
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.User
 import Utility.SafeCommand
 
-{- | Clones Joey Hess's git home directory, and runs its fixups script. -}
+-- | 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)
@@ -14,15 +14,20 @@ installedFor user = check (not <$> hasGitDir user) $
  	go Nothing = noChange
 	go (Just home) = do
 		let tmpdir = home </> "githome"
-		ok <- boolSystem "git" [Param "clone", Param url, Param tmpdir]
-			<&&> (and <$> moveout tmpdir home)
-			<&&> (catchBoolIO $ removeDirectory tmpdir >> return True)
-			<&&> boolSystem "su" [Param "-c", Param "cd; rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups", Param user]
-		return $ if ok then MadeChange else FailedChange
+		ensureProperty $ combineProperties
+			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
+			, Property "moveout" $ makeChange $ void $
+				moveout tmpdir home
+			, Property "rmdir" $ makeChange $ void $
+				catchMaybeIO $ removeDirectory tmpdir
+			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; mr checkout; bin/fixups"]
+			]
 	moveout tmpdir home = do
 		fs <- dirContents tmpdir
 		forM fs $ \f -> boolSystem "mv" [File f, File home]
-	url = "git://git.kitenet.net/joey/home"
+
+url :: String
+url = "git://git.kitenet.net/joey/home"
 
 hasGitDir :: UserName -> IO Bool
 hasGitDir user = go =<< homedir user

Propellor/Property/SiteSpecific/JoeySites.hs

@@ -1,7 +1,7 @@
 -- | Specific configuation for Joey Hess's sites. Probably not useful to
 -- others except as an example.
 
-module Propellor.Property.JoeySites where
+module Propellor.Property.SiteSpecific.JoeySites where
 
 import Propellor
 import qualified Propellor.Property.Apt as Apt

Propellor/Property/User.hs

@@ -6,15 +6,15 @@ import Propellor
 
 data Eep = YesReallyDeleteHome
 
-sshAccountFor :: UserName -> Property
-sshAccountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
+accountFor :: UserName -> Property
+accountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
 	[ "--disabled-password"
 	, "--gecos", ""
 	, user
 	]
 	`describe` ("ssh account " ++ user)
 
-{- | Removes user home directory!! Use with caution. -}
+-- | Removes user home directory!! Use with caution.
 nuked :: UserName -> Eep -> Property
 nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"
 	[ "-r"
@@ -22,8 +22,8 @@ nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"
 	]
 	`describe` ("nuked user " ++ user)
 
-{- | Only ensures that the user has some password set. It may or may
- - not be the password from the PrivData. -}
+-- | Only ensures that the user has some password set. It may or may
+-- not be the password from the PrivData.
 hasSomePassword :: UserName -> Property
 hasSomePassword user = check ((/= HasPassword) <$> getPasswordStatus user) $
 	hasPassword user

Propellor/Types.hs

@@ -26,6 +26,24 @@ instance Monoid Result where
 	mappend _ MadeChange = MadeChange
 	mappend NoChange NoChange = NoChange
 
+-- | High level descritption of a operating system.
+data System = System Distribution Architecture
+	deriving (Show)
+
+data Distribution
+	= Debian DebianSuite
+	| Ubuntu Release
+	deriving (Show)
+
+data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
+	deriving (Show)
+
+type Release = String
+
+data Architecture = Amd64 | I386 | Armel
+	deriving (Show)
+
+-- | Results of actions, with color.
 class ActionResult a where
 	getActionResult :: a -> (String, ColorIntensity, Color)
 

config.hs

@@ -14,8 +14,9 @@ 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.Docker as Docker
-import qualified Propellor.Property.GitHome as GitHome
-import qualified Propellor.Property.JoeySites as JoeySites
+import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
+import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
+import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
 
 main :: IO ()
 main = defaultMain [host, Docker.containerProperties container]
@@ -28,7 +29,7 @@ main = defaultMain [host, Docker.containerProperties container]
 host :: HostName -> Maybe [Property]
 host hostname@"clam.kitenet.net" = Just
 	[ cleanCloudAtCost hostname
-	, standardSystem Apt.Unstable
+	, standardSystem Unstable
 	, Apt.unattendedUpgrades True
 	, Network.ipv6to4
 	-- Clam is a tor bridge, and an olduse.net shellbox and other
@@ -37,15 +38,16 @@ host hostname@"clam.kitenet.net" = Just
 	, JoeySites.oldUseNetshellBox
 	, Docker.configured
 	, File.dirExists "/var/www"
-	, Docker.hasContainer hostname "webserver" container
+	, Docker.docked container hostname "webserver"
 	, Apt.installed ["git-annex", "mtr"]
 	-- Should come last as it reboots.
 	, Apt.installed ["systemd-sysv"] `onChange` Reboot.now
 	]
-host "orca.kitenet.net" = Just
-	[ standardSystem Apt.Unstable
+host hostname@"orca.kitenet.net" = Just
+	[ standardSystem Unstable
 	, Apt.unattendedUpgrades True
 	, Docker.configured
+	, Docker.docked container hostname "git-annex-amd64-builder"
 	]
 -- add more hosts here...
 --host "foo.example.com" =
@@ -54,7 +56,8 @@ 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 _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
+container _ "webserver" = Just $ Docker.containerFrom
+	(image $ System (Debian Unstable) Amd64)
 	[ Docker.publish "8080:80"
 	, Docker.volume "/var/www:/var/www"
 	, Docker.inside
@@ -62,10 +65,21 @@ container _ "webserver" = Just $ Docker.containerFrom "joeyh/debian-unstable"
 			`requires` Apt.installed ["apache2"]
 		]
 	]
+container _ "git-annex-amd64-builder" = Just $ Docker.containerFrom
+	(image $ System (Debian Unstable) Amd64)
+	[ Docker.inside [ GitAnnexBuilder.builder "amd64" "30 * * * *" ] ]
 container _ _ = Nothing
 
+-- | Docker images I prefer to use.
+-- Edit as suites you, or delete this function and just put the image names
+-- above.
+image :: System -> Docker.Image
+image (System (Debian Unstable) Amd64) = "joeyh/debian-unstable"
+image (System (Debian Unstable) I386) = "joeyh/debian-i386"
+image _ = "debian"
+
 -- This is my standard system setup
-standardSystem :: Apt.Suite -> Property
+standardSystem :: DebianSuite -> Property
 standardSystem suite = propertyList "standard system"
 	[ Apt.stdSourcesList suite `onChange` Apt.upgrade
 	, Apt.installed ["etckeeper"]
@@ -76,7 +90,7 @@ standardSystem suite = propertyList "standard system"
 	-- is safely in place.
 	, check (Ssh.hasAuthorizedKeys "root") $
 		Ssh.passwordAuthentication False
-	, User.sshAccountFor "joey"
+	, User.accountFor "joey"
 	, User.hasSomePassword "joey"
 	, Sudo.enabledFor "joey"
 	, GitHome.installedFor "joey"