Merge branch 'joeyconfig'

19 files changed, 660 insertions, 74 deletions

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 4bc1c2c7..94376b0d 100644
--- a/Propellor/Attr.hs
+++ b/Propellor/Attr.hs
@@ -8,6 +8,7 @@ import Propellor.Types.Attr
 import "mtl" Control.Monad.Reader
 import qualified Data.Set as S
 import qualified Data.Map as M
+import Control.Applicative
 
 pureAttrProperty :: Desc -> (Attr -> Attr) -> AttrProperty 
 pureAttrProperty desc = AttrProperty $ Property ("has " ++ desc)
@@ -20,6 +21,13 @@ hostname name = pureAttrProperty ("hostname " ++ name) $
 getHostName :: Propellor HostName
 getHostName = asks _hostname
 
+os :: System -> AttrProperty
+os system = pureAttrProperty ("Operating " ++ show system) $
+	\d -> d { _os = Just system }
+
+getOS :: Propellor (Maybe System)
+getOS = asks _os
+
 cname :: Domain -> AttrProperty
 cname domain = pureAttrProperty ("cname " ++ domain) (addCName domain)
 
@@ -31,6 +39,13 @@ cnameFor domain mkp =
 addCName :: HostName -> Attr -> Attr
 addCName domain d = d { _cnames = S.insert domain (_cnames d) }
 
+sshPubKey :: String -> AttrProperty
+sshPubKey k = pureAttrProperty ("ssh pubkey known") $
+	\d -> d { _sshPubKey = Just k }
+
+getSshPubKey :: Propellor (Maybe String)
+getSshPubKey = asks _sshPubKey
+
 hostnameless :: Attr
 hostnameless = newAttr (error "hostname Attr not specified")
 
@@ -45,3 +60,12 @@ hostMap l = M.fromList $ zip (map (_hostname . hostAttr) l) l
 
 findHost :: [Host] -> HostName -> Maybe Host
 findHost l hn = M.lookup hn (hostMap l)
+
+-- | Lifts an action into a different host.
+--
+-- For example, `fromHost hosts "otherhost" getSshPubKey`
+fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
+fromHost l hn getter = case findHost l hn of
+	Nothing -> return Nothing
+	Just h -> liftIO $ Just <$>
+		runReaderT (runWithAttr getter) (hostAttr h)
diff --git a/Propellor/Message.hs b/Propellor/Message.hs
index 2e63061e..780471c3 100644
--- a/Propellor/Message.hs
+++ b/Propellor/Message.hs
@@ -29,7 +29,7 @@ actionMessage desc a = do
 	return r
 
 warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ colorLine Vivid Red $ "** warning: " ++ s
+warningMessage s = liftIO $ colorLine Vivid Magenta $ "** warning: " ++ s
 
 colorLine :: ColorIntensity -> Color -> String -> IO ()
 colorLine intensity color msg = do
@@ -43,7 +43,7 @@ colorLine intensity color msg = do
 
 errorMessage :: String -> IO a
 errorMessage s = do
-	warningMessage s
+	liftIO $ colorLine Vivid Red $ "** error: " ++ s
 	error "Cannot continue!"
 
 -- | Causes a debug message to be displayed when PROPELLOR_DEBUG=1
diff --git a/Propellor/PrivData.hs b/Propellor/PrivData.hs
index c7af1aac..ad2c8d22 100644
--- a/Propellor/PrivData.hs
+++ b/Propellor/PrivData.hs
@@ -8,6 +8,7 @@ import System.FilePath
 import System.IO
 import System.Directory
 import Data.Maybe
+import Data.List
 import Control.Monad
 import "mtl" Control.Monad.Reader
 
@@ -30,9 +31,12 @@ withPrivData field a = maybe missing a =<< liftIO (getPrivData field)
   where
 	missing = do
 		host <- getHostName
+		let host' = if ".docker" `isSuffixOf` host
+			then "$parent_host"
+			else host
 		liftIO $ do
 			warningMessage $ "Missing privdata " ++ show field
-			putStrLn $ "Fix this by running: propellor --set "++host++" '" ++ show field ++ "'"
+			putStrLn $ "Fix this by running: propellor --set "++host'++" '" ++ show field ++ "'"
 			return FailedChange
 
 getPrivData :: PrivDataField -> IO (Maybe String)
diff --git a/Propellor/Property.hs b/Propellor/Property.hs
index 83e19a73..95d17c05 100644
--- a/Propellor/Property.hs
+++ b/Propellor/Property.hs
@@ -10,8 +10,10 @@ import "mtl" Control.Monad.Reader
 
 import Propellor.Types
 import Propellor.Types.Attr
+import Propellor.Attr
 import Propellor.Engine
 import Utility.Monad
+import System.FilePath
 
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange
@@ -52,14 +54,19 @@ p1 `before` p2 = Property (propertyDesc p1) $ do
 -- file to indicate whether it has run before.
 -- Use with caution.
 flagFile :: Property -> FilePath -> Property
-flagFile property flagfile = Property (propertyDesc property) $
-	go =<< liftIO (doesFileExist flagfile)
+flagFile property = flagFile' property . return
+
+flagFile' :: Property -> IO FilePath -> Property
+flagFile' property getflagfile = Property (propertyDesc property) $ do
+	flagfile <- liftIO getflagfile
+	go flagfile =<< liftIO (doesFileExist flagfile)
   where
-	go True = return NoChange
-	go False = do
+	go _ True = return NoChange
+	go flagfile False = do
 		r <- ensureProperty property
 		when (r == MadeChange) $ liftIO $ 
-			unlessM (doesFileExist flagfile) $
+			unlessM (doesFileExist flagfile) $ do
+				createDirectoryIfMissing True (takeDirectory flagfile)
 				writeFile flagfile ""
 		return r
 
@@ -85,6 +92,13 @@ check c property = Property (propertyDesc property) $ ifM (liftIO c)
 	, return NoChange
 	)
 
+-- | Makes a property that is satisfied differently depending on the host's
+-- operating system. 
+--
+-- Note that the operating system may not be declared for some hosts.
+withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
+withOS desc a = Property desc $ a =<< getOS
+
 boolProperty :: Desc -> IO Bool -> Property
 boolProperty desc a = Property desc $ ifM (liftIO a)
 	( return MadeChange
diff --git a/Propellor/Property/Apache.hs b/Propellor/Property/Apache.hs
new file mode 100644
index 00000000..f45ef9df
--- /dev/null
+++ b/Propellor/Property/Apache.hs
@@ -0,0 +1,62 @@
+module Propellor.Property.Apache where
+
+import Propellor
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+
+type ConfigFile = [String]
+
+siteEnabled :: HostName -> ConfigFile -> RevertableProperty
+siteEnabled hn cf = RevertableProperty enable disable
+  where
+	enable = cmdProperty "a2ensite" ["--quiet", hn]
+		`describe` ("apache site enabled " ++ hn)
+		`requires` siteAvailable hn cf
+		`requires` installed
+		`onChange` reloaded
+	disable = File.notPresent (siteCfg hn)
+		`describe` ("apache site disabled " ++ hn)
+		`onChange` cmdProperty "a2dissite" ["--quiet", hn]
+		`requires` installed
+		`onChange` reloaded
+
+siteAvailable :: HostName -> ConfigFile -> Property
+siteAvailable hn cf = siteCfg hn `File.hasContent` (comment:cf)
+	`describe` ("apache site available " ++ hn)
+  where
+	comment = "# deployed with propellor, do not modify"
+
+modEnabled :: String -> RevertableProperty
+modEnabled modname = RevertableProperty enable disable
+  where
+	enable = cmdProperty "a2enmod" ["--quiet", modname]
+		`describe` ("apache module enabled " ++ modname)
+		`requires` installed
+		`onChange` reloaded
+	disable = cmdProperty "a2dismod" ["--quiet", modname]
+		`describe` ("apache module disabled " ++ modname)
+		`requires` installed
+		`onChange` reloaded
+
+siteCfg :: HostName -> FilePath
+siteCfg hn = "/etc/apache2/sites-available/" ++ hn
+
+installed :: Property
+installed = Apt.installed ["apache2"]
+
+restarted :: Property
+restarted = cmdProperty "service" ["apache2", "restart"]
+
+reloaded :: Property
+reloaded = Service.reloaded "apache2"
+
+-- | Configure apache to use SNI to differentiate between
+-- https hosts.
+multiSSL :: Property
+multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent`
+	[ "NameVirtualHost *:443"
+	, "SSLStrictSNIVHostCheck off"
+	]
+	`describe` "apache SNI enabled"
+	`onChange` reloaded
diff --git a/Propellor/Property/Apt.hs b/Propellor/Property/Apt.hs
index 4da13a2f..f45bc2e6 100644
--- a/Propellor/Property/Apt.hs
+++ b/Propellor/Property/Apt.hs
@@ -24,9 +24,12 @@ showSuite Unstable = "unstable"
 showSuite Experimental = "experimental"
 showSuite (DebianRelease r) = r
 
-debLine :: DebianSuite -> Url -> [Section] -> Line
+backportSuite :: String
+backportSuite = showSuite stableRelease ++ "-backports"
+
+debLine :: String -> Url -> [Section] -> Line
 debLine suite mirror sections = unwords $
-	["deb", mirror, showSuite suite] ++ sections
+	["deb", mirror, suite] ++ sections
 
 srcLine :: Line -> Line
 srcLine l = case words l of
@@ -37,9 +40,12 @@ stdSections :: [Section]
 stdSections = ["main", "contrib", "non-free"]
 
 binandsrc :: String -> DebianSuite -> [Line]
-binandsrc url suite = [l, srcLine l]
+binandsrc url suite
+	| isStable suite = [l, srcLine l, bl, srcLine bl]
+	| otherwise = [l, srcLine l]
   where
-	l = debLine suite url stdSections
+	l = debLine (showSuite suite) url stdSections
+	bl = debLine backportSuite url stdSections
 
 debCdn :: DebianSuite -> [Line]
 debCdn = binandsrc "http://cdn.debian.net/debian"
@@ -50,7 +56,7 @@ kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
 -- | Only available for Stable and Testing
 securityUpdates :: DebianSuite -> [Line]
 securityUpdates suite
-	| suite == Stable || suite == Testing =
+	| isStable suite || suite == Testing =
 		let l = "deb http://security.debian.org/ " ++ showSuite suite ++ "/updates " ++ unwords stdSections
 		in [l, srcLine l]
 	| otherwise = []
@@ -62,7 +68,7 @@ securityUpdates suite
 -- kernel.org.
 stdSourcesList :: DebianSuite -> Property
 stdSourcesList suite = setSourcesList
-	(debCdn suite ++ kernelOrg suite ++ securityUpdates suite)
+	(concatMap (\gen -> gen suite) [debCdn, kernelOrg, securityUpdates])
 	`describe` ("standard sources.list for " ++ show suite)
 
 setSourcesList :: [Line] -> Property
@@ -96,6 +102,17 @@ installed' params ps = robustly $ check (isInstallable ps) go
   where
 	go = runApt $ params ++ ["install"] ++ ps
 
+installedBackport :: [Package] -> Property
+installedBackport ps = withOS desc $ \o -> case o of
+	Nothing -> error "cannot install backports; os not declared"
+	(Just (System (Debian suite) _))
+		| isStable suite -> 
+			ensureProperty $ runApt $ 
+				["install", "-t", backportSuite, "-y"] ++ ps
+	_ -> error $ "backports not supported on " ++ show o
+  where
+	desc = (unwords $ "apt installed backport":ps)
+
 -- | Minimal install of package, without recommends.
 installedMin :: [Package] -> Property
 installedMin = installed' ["--no-install-recommends", "-y"]
diff --git a/Propellor/Property/Cron.hs b/Propellor/Property/Cron.hs
index fa6019ea..2fa9c87e 100644
--- a/Propellor/Property/Cron.hs
+++ b/Propellor/Property/Cron.hs
@@ -4,13 +4,15 @@ import Propellor
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 
+import Data.Char
+
 type CronTimes = String
 
 -- | Installs a cron job, run as a specificed user, in a particular
 --directory. Note that the Desc must be unique, as it is used for the 
 --cron.d/ filename.
 job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
-job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`
+job desc times user cddir command = cronjobfile `File.hasContent`
 	[ "# Generated by propellor"
 	, ""
 	, "SHELL=/bin/sh"
@@ -20,6 +22,11 @@ job desc times user cddir command = ("/etc/cron.d/" ++ desc) `File.hasContent`
 	]
 	`requires` Apt.serviceInstalledRunning "cron"
 	`describe` ("cronned " ++ desc)
+  where
+	cronjobfile = "/etc/cron.d/" ++ map sanitize desc
+	sanitize c
+		| isAlphaNum c = c
+		| otherwise = '_'
 
 -- | Installs a cron job, and runs it niced and ioniced.
 niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property
diff --git a/Propellor/Property/File.hs b/Propellor/Property/File.hs
index 10dee75e..8f23dab7 100644
--- a/Propellor/Property/File.hs
+++ b/Propellor/Property/File.hs
@@ -1,8 +1,10 @@
 module Propellor.Property.File where
 
 import Propellor
+import Utility.FileMode
 
 import System.Posix.Files
+import System.PosixCompat.Types
 
 type Line = String
 
@@ -12,19 +14,31 @@ 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.
+--
+-- The file's permissions are preserved if the file already existed.
+-- Otherwise, they're set to 600.
 hasPrivContent :: FilePath -> Property
-hasPrivContent f = Property ("privcontent " ++ f) $
-	withPrivData (PrivFile f) (\v -> ensureProperty $ f `hasContent` lines v)
+hasPrivContent f = Property desc $ withPrivData (PrivFile f) $ \privcontent -> 
+	ensureProperty $ fileProperty' writeFileProtected desc
+		(\_oldcontent -> lines privcontent) f
+  where
+	desc = "privcontent " ++ f
+
+-- | Leaves the file world-readable.
+hasPrivContentExposed :: FilePath -> Property
+hasPrivContentExposed f = hasPrivContent f `onChange`
+	mode f (combineModes (ownerWriteMode:readModes))
 
 -- | Ensures that a line is present in a file, adding it to the end if not.
 containsLine :: FilePath -> Line -> Property
-f `containsLine` l = fileProperty (f ++ " contains:" ++ l) go f
+f `containsLine` l = f `containsLines` [l]
+
+containsLines :: FilePath -> [Line] -> Property
+f `containsLines` l = fileProperty (f ++ " contains:" ++ show l) go f
   where
 	go ls
-		| l `elem` ls = ls
-		| otherwise = ls++[l]
+		| all (`elem` ls) l = ls
+		| otherwise = ls++l
 
 -- | Ensures that a line is not present in a file.
 -- Note that the file is ensured to exist, so if it doesn't, an empty
@@ -38,7 +52,9 @@ notPresent f = check (doesFileExist f) $ Property (f ++ " not present") $
 	makeChange $ nukeFile f
 
 fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property
-fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)
+fileProperty = fileProperty' writeFile
+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property
+fileProperty' writer desc a f = Property desc $ go =<< liftIO (doesFileExist f)
   where
 	go True = do
 		ls <- liftIO $ lines <$> readFile f
@@ -46,13 +62,15 @@ fileProperty desc a f = Property desc $ go =<< liftIO (doesFileExist f)
 		if ls' == ls
 			then noChange
 			else makeChange $ viaTmp updatefile f (unlines ls')
-	go False = makeChange $ writeFile f (unlines $ a [])
+	go False = makeChange $ writer f (unlines $ a [])
 
 	-- viaTmp makes the temp file mode 600.
-	-- Replicate the original file mode before moving it into place.
+	-- Replicate the original file's owner and mode.
 	updatefile f' content = do
-		writeFile f' content
-		getFileStatus f >>= setFileMode f' . fileMode
+		writer f' content
+		s <- getFileStatus f
+		setFileMode f' (fileMode s)
+		setOwnerAndGroup f' (fileOwner s) (fileGroup s)
 
 -- | Ensures a directory exists.
 dirExists :: FilePath -> Property
@@ -68,3 +86,9 @@ ownerGroup f owner group = Property (f ++ " owner " ++ og) $ do
 		else noChange
   where
 	og = owner ++ ":" ++ group
+
+-- | Ensures that a file/dir has the specfied mode.
+mode :: FilePath -> FileMode -> Property
+mode f v = Property (f ++ " mode " ++ show v) $ do
+	liftIO $ modifyFileMode f (\_old -> v)
+	noChange
diff --git a/Propellor/Property/Git.hs b/Propellor/Property/Git.hs
index c0494160..1dae94bf 100644
--- a/Propellor/Property/Git.hs
+++ b/Propellor/Property/Git.hs
@@ -4,6 +4,7 @@ import Propellor
 import Propellor.Property.File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Service as Service
+import Utility.SafeCommand
 
 import Data.List
 
@@ -46,3 +47,43 @@ daemonRunning exportdir = RevertableProperty setup unsetup
 		, "--base-path=" ++ exportdir
 		, exportdir
 		]
+
+installed :: Property
+installed = Apt.installed ["git"]
+
+type RepoUrl = String
+
+type Branch = String
+
+-- | Specified git repository is cloned to the specified directory.
+--
+-- If the firectory exists with some other content, it will be recursively
+-- deleted.
+--
+-- A branch can be specified, to check out.
+cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
+cloned owner url dir mbranch = check originurl (Property desc checkout)
+	`requires` installed
+  where
+	desc = "git cloned " ++ url ++ " to " ++ dir
+	gitconfig = dir </> ".git/config"
+	originurl = ifM (doesFileExist gitconfig)
+		( do
+			v <- catchDefaultIO Nothing $ headMaybe . lines <$>
+				readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]
+			return (v /= Just url)
+		, return True
+		)
+	checkout = do
+		liftIO $ do
+			whenM (doesDirectoryExist dir) $
+				removeDirectoryRecursive dir
+			createDirectoryIfMissing True (takeDirectory dir)
+		ensureProperty $ userScriptProperty owner $ catMaybes
+			-- The </dev/null fixes an intermittent
+			-- "fatal: read error: Bad file descriptor"
+			-- when run across ssh with propellor --spin
+			[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
+			, Just $ "cd " ++ shellEscape dir
+			, ("git checkout " ++) <$> mbranch
+			]
diff --git a/Propellor/Property/Gpg.hs b/Propellor/Property/Gpg.hs
new file mode 100644
index 00000000..e23111bb
--- /dev/null
+++ b/Propellor/Property/Gpg.hs
@@ -0,0 +1,41 @@
+module Propellor.Property.Gpg where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import Utility.FileSystemEncoding
+
+import System.PosixCompat
+
+installed :: Property
+installed = Apt.installed ["gnupg"]
+
+-- | Sets up a user with a gpg key from the privdata.
+--
+-- Note that if a secret key is exported using gpg -a --export-secret-key,
+-- the public key is also included. Or just a public key could be
+-- exported, and this would set it up just as well.
+--
+-- Recommend only using this for low-value dedicated role keys.
+-- No attempt has been made to scrub the key out of memory once it's used.
+--
+-- The GpgKeyId does not have to be a numeric id; it can just as easily
+-- be a description of the key.
+keyImported :: GpgKeyId -> UserName -> Property
+keyImported keyid user = flagFile' (Property desc go) genflag
+	`requires` installed
+  where
+	desc = user ++ " has gpg key " ++ show keyid
+	genflag = do
+		d <- dotDir user
+		return $ d </> ".propellor-imported-keyid-" ++ keyid
+	go = withPrivData (GpgKey keyid) $ \key -> makeChange $
+		withHandle StdinHandle createProcessSuccess
+			(proc "su" ["-c", "gpg --import", user]) $ \h -> do
+				fileEncoding h
+				hPutStr h key
+				hClose h
+
+dotDir :: UserName -> IO FilePath
+dotDir user = do
+	home <- homeDirectory <$> getUserEntryForName user
+	return $ home </> ".gnupg"
diff --git a/Propellor/Property/Obnam.hs b/Propellor/Property/Obnam.hs
new file mode 100644
index 00000000..00e0bbef
--- /dev/null
+++ b/Propellor/Property/Obnam.hs
@@ -0,0 +1,96 @@
+module Propellor.Property.Obnam where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Cron as Cron
+import Utility.SafeCommand
+
+import Data.List
+
+installed :: Property
+installed = Apt.installed ["obnam"]
+
+type ObnamParam = String
+
+-- | An obnam repository can be used by multiple clients. Obnam uses
+-- locking to allow only one client to write at a time. Since stale lock
+-- files can prevent backups from happening, it's more robust, if you know
+-- a repository has only one client, to force the lock before starting a
+-- backup. Using OnlyClient allows propellor to do so when running obnam.
+data NumClients = OnlyClient | MultipleClients
+	deriving (Eq)
+
+-- | Installs a cron job that causes a given directory to be backed
+-- up, by running obnam with some parameters.
+--
+-- If the directory does not exist, or exists but is completely empty,
+-- this Property will immediately restore it from an existing backup.
+--
+-- So, this property can be used to deploy a directory of content
+-- to a host, while also ensuring any changes made to it get backed up.
+-- And since Obnam encrypts, just make this property depend on a gpg
+-- key, and tell obnam to use the key, and your data will be backed
+-- up securely. For example: 
+--
+-- >	& Obnam.backup "/srv/git" "33 3 * * *"
+-- >		[ "--repository=sftp://2318@usw-s002.rsync.net/~/mygitrepos.obnam"
+-- >		, "--encrypt-with=1B169BE1"
+-- >		] Obnam.OnlyClient
+-- >		`requires` Gpg.keyImported "1B169BE1" "root"
+-- >		`requires` Ssh.keyImported SshRsa "root"
+--
+-- How awesome is that?
+backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup dir crontimes params numclients = cronjob `describe` desc
+	`requires` restored dir params
+  where
+	desc = dir ++ " backed up by obnam"
+	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $
+		intercalate ";" $ catMaybes
+			[ if numclients == OnlyClient
+				then Just $ unwords $
+					[ "obnam"
+					, "force-lock"
+					] ++ map shellEscape params
+				else Nothing
+			, Just $ unwords $
+				[ "obnam"
+				, "backup"
+				, shellEscape dir
+				] ++ map shellEscape params
+			]
+
+-- | Restores a directory from an obnam backup.
+--
+-- Only does anything if the directory does not exist, or exists,
+-- but is completely empty.
+--
+-- The restore is performed atomically; restoring to a temp directory
+-- and then moving it to the directory.
+restored :: FilePath -> [ObnamParam] -> Property
+restored dir params = Property (dir ++ " restored by obnam") go
+	`requires` installed
+  where
+	go = ifM (liftIO needsRestore)
+		( do
+			warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
+			liftIO restore
+		, noChange
+		)
+
+	needsRestore = null <$> catchDefaultIO [] (dirContents dir)
+
+	restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do
+		ok <- boolSystem "obnam" $
+			[ Param "restore"
+			, Param "--to"
+			, Param tmpdir
+			] ++ map Param params
+		let restoreddir = tmpdir ++ "/" ++ dir
+		ifM (pure ok <&&> doesDirectoryExist restoreddir)
+			( do
+				void $ tryIO $ removeDirectory dir
+				renameDirectory restoreddir dir
+				return MadeChange
+			, return FailedChange
+			)
diff --git a/Propellor/Property/OpenId.hs b/Propellor/Property/OpenId.hs
index c397bdb8..051d6425 100644
--- a/Propellor/Property/OpenId.hs
+++ b/Propellor/Property/OpenId.hs
@@ -12,15 +12,18 @@ providerFor users baseurl = propertyList desc $
 	[ Apt.serviceInstalledRunning "apache2"
 	, Apt.installed ["simpleid"]
 		`onChange` Service.restarted "apache2"
-	, File.fileProperty desc
+	, File.fileProperty (desc ++ " configured")
 		(map setbaseurl) "/etc/simpleid/config.inc"
 	] ++ map identfile users
   where
-	identfile u = File.hasPrivContent $ concat
-		[ "/var/lib/simpleid/identities/", u, ".identity" ]
 	url = "http://"++baseurl++"/simpleid"
 	desc = "openid provider " ++ url
 	setbaseurl l
 		| "SIMPLEID_BASE_URL" `isInfixOf` l = 
 			"define('SIMPLEID_BASE_URL', '"++url++"');"
 		| otherwise = l
+	
+	-- the identitites directory controls access, so open up
+	-- file mode
+	identfile u = File.hasPrivContentExposed $
+		concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ]
diff --git a/Propellor/Property/SiteSpecific/GitHome.hs b/Propellor/Property/SiteSpecific/GitHome.hs
index 1ba56b94..ee46a9e4 100644
--- a/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/Propellor/Property/SiteSpecific/GitHome.hs
@@ -11,8 +11,7 @@ installedFor user = check (not <$> hasGitDir user) $
 	Property ("githome " ++ user) (go =<< liftIO (homedir user))
 		`requires` Apt.installed ["git"]
   where
- 	go Nothing = noChange
-	go (Just home) = do
+	go home = do
 		let tmpdir = home </> "githome"
 		ensureProperty $ combineProperties "githome setup"
 			[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
@@ -32,5 +31,4 @@ url = "git://git.kitenet.net/joey/home"
 hasGitDir :: UserName -> IO Bool
 hasGitDir user = go =<< homedir user
   where
-	go Nothing = return False
-	go (Just home) = doesDirectoryExist (home </> ".git")
+	go home = doesDirectoryExist (home </> ".git")
diff --git a/Propellor/Property/SiteSpecific/JoeySites.hs b/Propellor/Property/SiteSpecific/JoeySites.hs
index 46373170..73a8f71f 100644
--- a/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -5,6 +5,15 @@ module Propellor.Property.SiteSpecific.JoeySites where
 
 import Propellor
 import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Gpg as Gpg
+import qualified Propellor.Property.Ssh as Ssh
+import qualified Propellor.Property.Git as Git
+import qualified Propellor.Property.Service as Service
+import qualified Propellor.Property.User as User
+import qualified Propellor.Property.Obnam as Obnam
+import qualified Propellor.Property.Apache as Apache
+import Utility.SafeCommand
 
 oldUseNetShellBox :: Property
 oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
@@ -21,3 +30,142 @@ oldUseNetShellBox = check (not <$> Apt.isInstalled "oldusenet") $
 			, "rm -rf /root/tmp/oldusenet"
 			] `describe` "olduse.net built"
 		]
+
+kgbServer :: Property
+kgbServer = withOS desc $ \o -> case o of
+	(Just (System (Debian Unstable) _)) ->
+		ensureProperty $ propertyList desc
+			[ Apt.serviceInstalledRunning "kgb-bot"
+			, File.hasPrivContent "/etc/kgb-bot/kgb.conf"
+				`onChange` Service.restarted "kgb-bot"
+			, "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
+				`describe` "kgb bot enabled"
+				`onChange` Service.running "kgb-bot"
+			]
+	_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
+  where
+	desc = "kgb.kitenet.net setup"
+
+-- git.kitenet.net and git.joeyh.name
+gitServer :: [Host] -> Property
+gitServer hosts = propertyList "git.kitenet.net setup"
+	[ Obnam.backup "/srv/git" "33 3 * * *"
+		[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
+		, "--encrypt-with=1B169BE1"
+		, "--client-name=wren"
+		] Obnam.OnlyClient
+		`requires` Gpg.keyImported "1B169BE1" "root"
+		`requires` Ssh.keyImported SshRsa "root"
+		`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
+		`requires` Ssh.authorizedKeys "family"
+		`requires` User.accountFor "family"
+	, Apt.installed ["git", "rsync", "kgb-client-git", "gitweb"]
+	, Apt.installedBackport ["git-annex"]
+	, File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf"
+	, toProp $ Git.daemonRunning "/srv/git"
+	, "/etc/gitweb.conf" `File.containsLines`
+		[ "$projectroot = '/srv/git';"
+		, "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');"
+		, "# disable snapshot download; overloads server"
+		, "$feature{'snapshot'}{'default'} = [];"
+		]
+		`describe` "gitweb configured"
+	-- Repos push on to github.
+	, Ssh.knownHost hosts "github.com" "joey"
+	-- I keep the website used for gitweb checked into git..
+	, Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing
+	, website "git.kitenet.net"
+	, website "git.joeyh.name"
+	, toProp $ Apache.modEnabled "cgi"
+	]
+  where
+	website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True
+		[ "  DocumentRoot /srv/web/git.kitenet.net/"
+		, "  <Directory /srv/web/git.kitenet.net/>"
+		, "    Options Indexes ExecCGI FollowSymlinks"
+		, "    AllowOverride None"
+		, "    AddHandler cgi-script .cgi"
+		, "    DirectoryIndex index.cgi"
+		, "  </Directory>"
+		, ""
+		, "  ScriptAlias /cgi-bin/ /usr/lib/cgi-bin/"
+		, "  <Directory /usr/lib/cgi-bin>"
+		, "    SetHandler cgi-script"
+		, "    Options ExecCGI"
+		, "  </Directory>"
+		]
+
+type AnnexUUID = String
+
+-- | A website, with files coming from a git-annex repository.
+annexWebSite :: [Host] -> Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property
+annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using git-annex")
+	[ Git.cloned "joey" origin dir Nothing
+		`onChange` setup
+	, setupapache
+	]
+  where
+	dir = "/srv/web/" ++ hn
+	setup = userScriptProperty "joey" setupscript
+		`requires` Ssh.keyImported SshRsa "joey"
+		`requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey"
+	setupscript = 
+		[ "cd " ++ shellEscape dir
+		, "git config annex.uuid " ++ shellEscape uuid
+		] ++ map addremote remotes ++
+		[ "git annex get"
+		]
+	addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url
+	setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ 
+		[ "  ServerAlias www."++hn
+		, ""
+		, "  DocumentRoot /srv/web/"++hn
+		, "  <Directory /srv/web/"++hn++">"
+		, "    Options FollowSymLinks"
+		, "    AllowOverride None"
+		, "  </Directory>"
+		, "  <Directory /srv/web/"++hn++">"
+		, "    Options Indexes FollowSymLinks ExecCGI"
+		, "    AllowOverride None"
+		, "    Order allow,deny"
+		, "    allow from all"
+		, "  </Directory>"
+		]
+
+apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
+apachecfg hn withssl middle
+	| withssl = vhost False ++ vhost True
+	| otherwise = vhost False
+  where
+	vhost ssl = 
+		[ "<VirtualHost *:"++show port++">"
+		, "  ServerAdmin grue@joeyh.name"
+		, "  ServerName "++hn++":"++show port
+		]
+		++ mainhttpscert ssl
+		++ middle ++
+		[ ""
+		, "  ErrorLog /var/log/apache2/error.log"
+		, "  LogLevel warn"
+		, "  CustomLog /var/log/apache2/access.log combined"
+		, "  ServerSignature On"
+		, "  "
+		, "  <Directory \"/usr/share/apache2/icons\">"
+		, "      Options Indexes MultiViews"
+		, "      AllowOverride None"
+		, "      Order allow,deny"
+		, "      Allow from all"
+		, "  </Directory>"
+		, "</VirtualHost>"
+		]
+	  where
+		port = if ssl then 443 else 80 :: Int
+
+mainhttpscert :: Bool -> Apache.ConfigFile
+mainhttpscert False = []
+mainhttpscert True = 
+	[ "  SSLEngine on"
+	, "  SSLCertificateFile /etc/ssl/certs/web.pem"
+	, "  SSLCertificateKeyFile /etc/ssl/private/web.pem"
+	, "  SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
+	]
diff --git a/Propellor/Property/Ssh.hs b/Propellor/Property/Ssh.hs
index 59845f8f..b13a12bf 100644
--- a/Propellor/Property/Ssh.hs
+++ b/Propellor/Property/Ssh.hs
@@ -4,13 +4,20 @@ module Propellor.Property.Ssh (
 	passwordAuthentication,
 	hasAuthorizedKeys,
 	restartSshd,
-	uniqueHostKeys
+	randomHostKeys,
+	hostKey,
+	keyImported,
+	knownHost,
+	authorizedKeys
 ) where
 
 import Propellor
 import qualified Propellor.Property.File as File
 import Propellor.Property.User
 import Utility.SafeCommand
+import Utility.FileMode
+
+import System.PosixCompat
 
 sshBool :: Bool -> String
 sshBool True = "yes"
@@ -35,12 +42,20 @@ permitRootLogin = setSshdConfig "PermitRootLogin"
 passwordAuthentication :: Bool -> Property
 passwordAuthentication = setSshdConfig "PasswordAuthentication"
 
+dotDir :: UserName -> IO FilePath
+dotDir user = do
+	h <- homedir user
+	return $ h </> ".ssh"
+
+dotFile :: FilePath -> UserName -> IO FilePath
+dotFile f user = do
+	d <- dotDir user
+	return $ d </> f
+
 hasAuthorizedKeys :: UserName -> IO Bool
-hasAuthorizedKeys = go <=< homedir
+hasAuthorizedKeys = go <=< dotFile "authorized_keys"
   where
-	go Nothing = return False
-	go (Just home) = not . null <$> catchDefaultIO ""
-		(readFile $ home </> ".ssh" </> "authorized_keys")
+	go f = not . null <$> catchDefaultIO "" (readFile f)
 
 restartSshd :: Property
 restartSshd = cmdProperty "service" ["ssh", "restart"]
@@ -48,11 +63,11 @@ restartSshd = cmdProperty "service" ["ssh", "restart"]
 -- | Blows away existing host keys and make new ones.
 -- Useful for systems installed from an image that might reuse host keys.
 -- A flag file is used to only ever do this once.
-uniqueHostKeys :: Property
-uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
+randomHostKeys :: Property
+randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 	`onChange` restartSshd
   where
-	prop = Property "ssh unique host keys" $ do
+	prop = Property "ssh random host keys" $ do
 		void $ liftIO $ boolSystem "sh"
 			[ Param "-c"
 			, Param "rm -f /etc/ssh/ssh_host_*"
@@ -60,3 +75,77 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 		ensureProperty $
 			cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"
 				["configure"]
+
+-- | Sets ssh host keys from the site's PrivData.
+-- 
+-- (Uses a null username for host keys.)
+hostKey :: SshKeyType -> Property
+hostKey keytype = combineProperties desc
+	[ Property desc (install writeFile (SshPubKey keytype "") ".pub")
+	, Property desc (install writeFileProtected (SshPrivKey keytype "") "")
+	]
+	`onChange` restartSshd
+  where
+ 	desc = "known ssh host key (" ++ fromKeyType keytype ++ ")"
+	install writer p ext = withPrivData p $ \key -> do
+		let f = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
+		s <- liftIO $ readFileStrict f
+		if s == key
+			then noChange
+			else makeChange $ writer f key
+
+-- | Sets up a user with a ssh private key and public key pair
+-- from the site's PrivData.
+keyImported :: SshKeyType -> UserName -> Property
+keyImported keytype user = combineProperties desc
+	[ Property desc (install writeFile (SshPubKey keytype user) ".pub")
+	, Property desc (install writeFileProtected (SshPrivKey keytype user) "")
+	]
+  where
+	desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")"
+	install writer p ext = do
+		f <- liftIO $ keyfile ext
+		ifM (liftIO $ doesFileExist f)
+			( noChange
+			, ensureProperty $ combineProperties desc
+				[ Property desc $ 
+					withPrivData p $ \key -> makeChange $
+						writer f key
+				, File.ownerGroup f user user
+				]
+			)
+	keyfile ext = do
+		home <- homeDirectory <$> getUserEntryForName user
+		return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext
+
+fromKeyType :: SshKeyType -> String
+fromKeyType SshRsa = "rsa"
+fromKeyType SshDsa = "dsa"
+fromKeyType SshEcdsa = "ecdsa"
+
+-- | Puts some host's ssh public key into the known_hosts file for a user.
+knownHost :: [Host] -> HostName -> UserName -> Property
+knownHost hosts hn user = Property desc $
+	go =<< fromHost hosts hn getSshPubKey
+  where
+	desc = user ++ " knows ssh key for " ++ hn
+	go (Just (Just k)) = do
+		f <- liftIO $ dotFile "known_hosts" user
+		ensureProperty $ combineProperties desc
+			[ File.dirExists (takeDirectory f)
+			, f `File.containsLine` (hn ++ " " ++ k)
+			, File.ownerGroup f user user
+			]
+	go _ = do
+		warningMessage $ "no configred sshPubKey for " ++ hn
+		return FailedChange
+
+-- | Makes a user have authorized_keys from the PrivData
+authorizedKeys :: UserName -> Property
+authorizedKeys user = Property (user ++ " has authorized_keys") $
+	withPrivData (SshAuthorizedKeys user) $ \v -> do
+		f <- liftIO $ dotFile "authorized_keys" user
+		liftIO $ do
+			createDirectoryIfMissing True (takeDirectory f)
+			writeFileProtected f v
+		ensureProperty $ File.ownerGroup f user user
diff --git a/Propellor/Property/User.hs b/Propellor/Property/User.hs
index 9d948834..8e7afd81 100644
--- a/Propellor/Property/User.hs
+++ b/Propellor/Property/User.hs
@@ -7,7 +7,7 @@ import Propellor
 data Eep = YesReallyDeleteHome
 
 accountFor :: UserName -> Property
-accountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
+accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser"
 	[ "--disabled-password"
 	, "--gecos", ""
 	, user
@@ -16,7 +16,7 @@ accountFor user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
 
 -- | Removes user home directory!! Use with caution.
 nuked :: UserName -> Eep -> Property
-nuked user _ = check (isJust <$> homedir user) $ cmdProperty "userdel"
+nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel"
 	[ "-r"
 	, user
 	]
@@ -57,5 +57,5 @@ getPasswordStatus user = parse . words <$> readProcess "passwd" ["-S", user]
 isLockedPassword :: UserName -> IO Bool
 isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
 
-homedir :: UserName -> IO (Maybe FilePath)
-homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user
+homedir :: UserName -> IO FilePath
+homedir user = homeDirectory <$> getUserEntryForName user
diff --git a/Propellor/Types.hs b/Propellor/Types.hs
index e6e02126..5f575daf 100644
--- a/Propellor/Types.hs
+++ b/Propellor/Types.hs
@@ -6,8 +6,6 @@ module Propellor.Types
 	( Host(..)
 	, Attr
 	, HostName
-	, UserName
-	, GroupName
 	, Propellor(..)
 	, Property(..)
 	, RevertableProperty(..)
@@ -19,14 +17,12 @@ module Propellor.Types
 	, requires
 	, Desc
 	, Result(..)
-	, System(..)
-	, Distribution(..)
-	, DebianSuite(..)
-	, Release
-	, Architecture
 	, ActionResult(..)
 	, CmdLine(..)
 	, PrivDataField(..)
+	, GpgKeyId
+	, SshKeyType(..)
+	, module Propellor.Types.OS
 	) where
 
 import Data.Monoid
@@ -36,12 +32,10 @@ import "mtl" Control.Monad.Reader
 import "MonadCatchIO-transformers" Control.Monad.CatchIO
 
 import Propellor.Types.Attr
+import Propellor.Types.OS
 
 data Host = Host [Property] (Attr -> Attr)
 
-type UserName = String
-type GroupName = String
-
 -- | Propellor's monad provides read-only access to attributes of the
 -- system.
 newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p }
@@ -117,22 +111,6 @@ 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, Eq)
-
-type Release = String
-
-type Architecture = String
-
 -- | Results of actions, with color.
 class ActionResult a where
 	getActionResult :: a -> (String, ColorIntensity, Color)
@@ -162,9 +140,15 @@ data CmdLine
 -- It's fine to add new fields.
 data PrivDataField
 	= DockerAuthentication
-	| SshPrivKey UserName
+	| SshPubKey SshKeyType UserName
+	| SshPrivKey SshKeyType UserName
+	| SshAuthorizedKeys UserName
 	| Password UserName
 	| PrivFile FilePath
+	| GpgKey GpgKeyId
 	deriving (Read, Show, Ord, Eq)
 
+type GpgKeyId = String
 
+data SshKeyType = SshRsa | SshDsa | SshEcdsa
+	deriving (Read, Show, Ord, Eq)
diff --git a/Propellor/Types/Attr.hs b/Propellor/Types/Attr.hs
index c253e32b..1ff58148 100644
--- a/Propellor/Types/Attr.hs
+++ b/Propellor/Types/Attr.hs
@@ -1,11 +1,15 @@
 module Propellor.Types.Attr where
 
+import Propellor.Types.OS
+
 import qualified Data.Set as S
 
 -- | The attributes of a host. For example, its hostname.
 data Attr = Attr
 	{ _hostname :: HostName
 	, _cnames :: S.Set Domain
+	, _os :: Maybe System
+	, _sshPubKey :: Maybe String
 
 	, _dockerImage :: Maybe String
 	, _dockerRunParams :: [HostName -> String]
@@ -15,6 +19,8 @@ instance Eq Attr where
 	x == y = and
 		[ _hostname x == _hostname y
 		, _cnames x == _cnames y
+		, _os x == _os y
+		, _sshPubKey x == _sshPubKey y
 
 		, _dockerImage x == _dockerImage y
 		, let simpl v = map (\a -> a "") (_dockerRunParams v)
@@ -25,12 +31,14 @@ instance Show Attr where
 	show a = unlines
 		[ "hostname " ++ _hostname a
 		, "cnames " ++ show (_cnames a)
+		, "OS " ++ show (_os a)
+		, "sshPubKey " ++ show (_sshPubKey a)
 		, "docker image " ++ show (_dockerImage a)
 		, "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a))
 		]
 
 newAttr :: HostName -> Attr
-newAttr hn = Attr hn S.empty Nothing []
+newAttr hn = Attr hn S.empty Nothing Nothing Nothing []
 
 type HostName = String
 type Domain = String
diff --git a/Propellor/Types/OS.hs b/Propellor/Types/OS.hs
new file mode 100644
index 00000000..0635b271
--- /dev/null
+++ b/Propellor/Types/OS.hs
@@ -0,0 +1,26 @@
+module Propellor.Types.OS where
+
+type UserName = String
+type GroupName = String
+
+-- | High level descritption of a operating system.
+data System = System Distribution Architecture
+	deriving (Show, Eq)
+
+data Distribution
+	= Debian DebianSuite
+	| Ubuntu Release
+	deriving (Show, Eq)
+
+data DebianSuite = Experimental | Unstable | Testing | Stable | DebianRelease Release
+	deriving (Show, Eq)
+
+-- | The release that currently corresponds to stable.
+stableRelease :: DebianSuite
+stableRelease = DebianRelease "wheezy"
+
+isStable :: DebianSuite -> Bool
+isStable s = s == Stable || s == stableRelease
+
+type Release = String
+type Architecture = String