propellor spin

Propellor/Property.hs

@@ -12,6 +12,7 @@ import Propellor.Types
 import Propellor.Types.Attr
 import Propellor.Engine
 import Utility.Monad
+import System.FilePath
 
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange
@@ -52,14 +53,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
 

Propellor/Property/Git.hs

@@ -65,7 +65,7 @@ cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property
 cloned owner url dir mbranch = check originurl (Property desc checkout)
 	`requires` installed
   where
-	desc = "git cloned " ++ url ++ " " ++ dir
+	desc = "git cloned " ++ url ++ " to " ++ dir
 	gitconfig = dir </> ".git/config"
 	originurl = ifM (doesFileExist gitconfig)
 		( do

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"

Propellor/Property/Ssh.hs

@@ -4,13 +4,17 @@ module Propellor.Property.Ssh (
 	passwordAuthentication,
 	hasAuthorizedKeys,
 	restartSshd,
-	uniqueHostKeys
+	uniqueHostKeys,
+	keyImported
 ) 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"
@@ -60,3 +64,24 @@ uniqueHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
 		ensureProperty $
 			cmdProperty "/var/lib/dpkg/info/openssh-server.postinst"
 				["configure"]
+
+-- | Sets up a user with a ssh private key from the site's privdata.
+--
+-- The ssh public key (.pub) is not installed. Ssh does not use it.
+keyImported :: SshKeyType -> UserName -> Property
+keyImported keytype user = Property desc install
+  where
+	desc = user ++ " has ssh key"
+	install = do
+		f <- liftIO keyfile
+		ifM (liftIO $ doesFileExist f)
+			( noChange
+			, withPrivData (SshKey keytype user) $ \key -> makeChange $
+				writeFileProtected f key
+			)
+	keyfile = do
+		home <- homeDirectory <$> getUserEntryForName user
+		return $ home </> ".ssh" </> "id_" ++ 
+			case keytype of
+				SshRsa -> "rsa"
+				SshDsa -> "dsa"

Propellor/Types.hs

@@ -27,6 +27,8 @@ module Propellor.Types
 	, ActionResult(..)
 	, CmdLine(..)
 	, PrivDataField(..)
+	, GpgKeyId
+	, SshKeyType(..)
 	) where
 
 import Data.Monoid
@@ -162,9 +164,13 @@ data CmdLine
 -- It's fine to add new fields.
 data PrivDataField
 	= DockerAuthentication
-	| SshPrivKey UserName
+	| SshKey SshKeyType UserName
 	| Password UserName
 	| PrivFile FilePath
+	| GpgKey GpgKeyId
 	deriving (Read, Show, Ord, Eq)
 
+type GpgKeyId = String
 
+data SshKeyType = SshRsa | SshDsa
+	deriving (Read, Show, Ord, Eq)

config-joey.hs

@@ -17,6 +17,7 @@ import qualified Propellor.Property.Dns as Dns
 import qualified Propellor.Property.OpenId as OpenId
 import qualified Propellor.Property.Docker as Docker
 import qualified Propellor.Property.Git as Git
+import qualified Propellor.Property.Gpg as Gpg
 import qualified Propellor.Property.SiteSpecific.GitHome as GitHome
 import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuilder
 import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
@@ -71,6 +72,8 @@ hosts =
 		& Apt.buildDep ["git-annex"] `period` Daily
 		& Git.daemonRunning "/srv/git"
 		& File.ownerGroup "/srv/git" "joey" "joey"
+		& Gpg.keyImported "git.kitenet.net obnam backup key" "root"
+		& Ssh.keyImported SshRsa "root"
 		-- git repos restore (how?) (also make backups!)
 		-- family annex needs family members to have accounts,
 		--     ssh host key etc.. finesse?
@@ -80,13 +83,13 @@ hosts =
 		-- gitweb
 		-- downloads.kitenet.net setup (including ssh key to turtle)
 
-  --'                        __|II|      ,.
-----                      __|II|II|__   (  \_,/\
------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-
---------------------- |      [Docker]       / ----------------------
---------------------- :                    / -----------------------
----------------------- \____, o          ,' ------------------------
------------------------ '--,___________,'  -------------------------
+	    --'                        __|II|      ,.
+	  ----                      __|II|II|__   (  \_,/\
+	 ------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/   __/ -'-.-'-.-'-.-'-.-'-
+	----------------------- |      [Docker]       / ----------------------
+	----------------------- :                    / -----------------------
+	------------------------ \____, o          ,' ------------------------
+	------------------------- '--,___________,'  -------------------------
 
 	-- Simple web server, publishing the outside host's /var/www
 	, standardContainer "webserver" Stable "amd64"

propellor.cabal

@@ -76,6 +76,7 @@ Library
     Propellor.Property.Docker
     Propellor.Property.File
     Propellor.Property.Git
+    Propellor.Property.Gpg
     Propellor.Property.Network
     Propellor.Property.OpenId
     Propellor.Property.Reboot