propellor spin

6 files changed, 84 insertions, 24 deletions

diff --git a/Propellor/Attr.hs b/Propellor/Attr.hs
index 4bc1c2c7..67ea8b8c 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)
@@ -31,6 +32,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 +53,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/Property/Obnam.hs b/Propellor/Property/Obnam.hs
index ebdcb9dd..b7d34223 100644
--- a/Propellor/Property/Obnam.hs
+++ b/Propellor/Property/Obnam.hs
@@ -5,11 +5,21 @@ 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.
 --
@@ -23,25 +33,32 @@ type ObnamParam = String
 -- up securely. For example: 
 --
 -- >	& Obnam.backup "/srv/git" "33 3 * * *"
--- >		[ "--repository=2318@usw-s002.rsync.net:mygitrepos.obnam"
+-- >		[ "--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] -> Property
-backup dir crontimes params = cronjob `describe` desc
+backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property
+backup dir crontimes params numclients = cronjob `describe` desc
 	`requires` restored dir params
-	`requires` installed
   where
 	desc = dir ++ " backed up by obnam"
 	cronjob = Cron.niceJob ("obnam_backup" ++ dir) crontimes "root" "/" $
-		unwords $
-			[ "obnam"
-			, "backup"
-			, shellEscape dir
-			] ++ map shellEscape params
+		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.
 --
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/Ssh.hs b/Propellor/Property/Ssh.hs
index 51649fd9..009511dd 100644
--- a/Propellor/Property/Ssh.hs
+++ b/Propellor/Property/Ssh.hs
@@ -5,7 +5,8 @@ module Propellor.Property.Ssh (
 	hasAuthorizedKeys,
 	restartSshd,
 	uniqueHostKeys,
-	keyImported
+	keyImported,
+	knownHost,
 ) where
 
 import Propellor
@@ -39,12 +40,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"]
@@ -87,3 +96,19 @@ keyImported keytype user = propertyList desc
 				SshRsa -> "rsa"
 				SshDsa -> "dsa"
 			++ ext
+
+-- | 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 $ propertyList desc
+			[ File.dirExists (takeDirectory f)
+			, f `File.containsLine` (hn ++ " " ++ k)
+			]
+	go _ = do
+		warningMessage $ "no configred sshPubKey for " ++ hn
+		return FailedChange
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/Attr.hs b/Propellor/Types/Attr.hs
index c253e32b..cdbe9ca3 100644
--- a/Propellor/Types/Attr.hs
+++ b/Propellor/Types/Attr.hs
@@ -6,6 +6,7 @@ import qualified Data.Set as S
 data Attr = Attr
 	{ _hostname :: HostName
 	, _cnames :: S.Set Domain
+	, _sshPubKey :: Maybe String
 
 	, _dockerImage :: Maybe String
 	, _dockerRunParams :: [HostName -> String]
@@ -15,6 +16,7 @@ instance Eq Attr where
 	x == y = and
 		[ _hostname x == _hostname y
 		, _cnames x == _cnames y
+		, _sshPubKey x == _sshPubKey y
 
 		, _dockerImage x == _dockerImage y
 		, let simpl v = map (\a -> a "") (_dockerRunParams v)
@@ -25,12 +27,13 @@ instance Show Attr where
 	show a = unlines
 		[ "hostname " ++ _hostname a
 		, "cnames " ++ show (_cnames 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 []
 
 type HostName = String
 type Domain = String