From 58f79c12aad3511b70f2233226d3f0afc5214b10 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Jul 2014 15:56:56 -0400 Subject: propellor spin --- src/Propellor/CmdLine.hs | 32 +++--- src/Propellor/PrivData.hs | 116 ++++++++++++--------- src/Propellor/Property/Docker.hs | 7 +- src/Propellor/Property/File.hs | 13 +-- src/Propellor/Property/Gpg.hs | 17 +-- src/Propellor/Property/OpenId.hs | 5 +- .../Property/SiteSpecific/GitAnnexBuilder.hs | 38 +++---- src/Propellor/Property/SiteSpecific/JoeySites.hs | 28 ++--- src/Propellor/Property/Ssh.hs | 45 ++++---- src/Propellor/Property/User.hs | 23 ++-- src/Propellor/Types.hs | 31 ++---- src/Propellor/Types/Info.hs | 5 +- src/Propellor/Types/PrivData.hs | 34 ++++++ 13 files changed, 218 insertions(+), 176 deletions(-) create mode 100644 src/Propellor/Types/PrivData.hs (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 1027fd8d..b6dd2bc1 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -27,10 +27,10 @@ usage = do , " propellor hostname" , " propellor --spin hostname" , " propellor --add-key keyid" - , " propellor --set hostname field" - , " propellor --dump hostname field" - , " propellor --edit hostname field" - , " propellor --list-fields hostname" + , " propellor --set field context" + , " propellor --dump field context" + , " propellor --edit field context" + , " propellor --list-fields" ] exitFailure @@ -41,10 +41,10 @@ processCmdLine = go =<< getArgs go ("--spin":h:[]) = return $ Spin h go ("--boot":h:[]) = return $ Boot h go ("--add-key":k:[]) = return $ AddKey k - go ("--set":h:f:[]) = withprivfield f (return . Set h) - go ("--dump":h:f:[]) = withprivfield f (return . Dump h) - go ("--edit":h:f:[]) = withprivfield f (return . Edit h) - go ("--list-fields":h:[]) = return $ ListFields h + go ("--set":f:c:[]) = withprivfield f c Set + go ("--dump":f:c:[]) = withprivfield f c Dump + go ("--edit":f:c:[]) = withprivfield f c Edit + go ("--list-fields":[]) = return ListFields go ("--continue":s:[]) = case readish s of Just cmdline -> return $ Continue cmdline Nothing -> errorMessage "--continue serialization failure" @@ -60,8 +60,8 @@ processCmdLine = go =<< getArgs else return $ Run s go _ = usage - withprivfield s f = case readish s of - Just pf -> f pf + withprivfield s c f = case readish s of + Just pf -> return $ f pf (Context c) Nothing -> errorMessage $ "Unknown privdata field " ++ s defaultMain :: [Host] -> IO () @@ -73,10 +73,10 @@ defaultMain hostlist = do go True cmdline where go _ (Continue cmdline) = go False cmdline - go _ (Set hn field) = setPrivData hn field - go _ (Dump hn field) = dumpPrivData hn field - go _ (Edit hn field) = editPrivData hn field - go _ (ListFields hn) = listPrivDataFields hn + go _ (Set field context) = setPrivData field context + go _ (Dump field context) = dumpPrivData field context + go _ (Edit field context) = editPrivData field context + go _ ListFields = listPrivDataFields go _ (AddKey keyid) = addKey keyid go _ (Chain hn) = withhost hn $ \h -> do r <- runPropellor h $ ensureProperties $ hostProperties h @@ -182,11 +182,11 @@ spin hn = do void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ boolSystem "git" [Param "push"] cacheparams <- toCommand <$> sshCachingParams hn - go cacheparams url =<< gpgDecrypt (privDataFile hn) + go cacheparams url =<< gpgDecrypt privDataFile where go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do let finish = do - senddata toh (privDataFile hn) privDataMarker privdata + senddata toh privDataLocal privDataMarker privdata hClose toh -- Display remaining output. diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index c2af4284..d57b2e6f 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -2,18 +2,20 @@ module Propellor.PrivData where -import qualified Data.Map as M import Control.Applicative import System.FilePath import System.IO import System.Directory import Data.Maybe -import Data.List +import Data.Monoid import Control.Monad import Control.Monad.IfElse import "mtl" Control.Monad.Reader +import qualified Data.Map as M +import qualified Data.Set as S import Propellor.Types +import Propellor.Types.Info import Propellor.Message import Utility.Monad import Utility.PartialPrelude @@ -25,40 +27,57 @@ import Utility.Misc import Utility.FileMode import Utility.Env --- | When the specified PrivDataField is available on the host Propellor --- is provisioning, it provies the data to the action. Otherwise, it prints --- a message to help the user make the necessary private data available. -withPrivData :: PrivDataField -> (String -> Propellor Result) -> Propellor Result -withPrivData field a = maybe missing a =<< liftIO (getPrivData field) +-- | Allows a Property to access the value of a specific PrivDataField, +-- for use in a specific Context. +-- +-- Example use: +-- +-- > withPrivData (PrivFile pemfile) (Context "joeyh.name") $ \getdata -> +-- > property "joeyh.name ssl cert" $ getdata $ \privdata -> +-- > liftIO $ writeFile pemfile privdata +-- > where pemfile = "/etc/ssl/certs/web.pem" +-- +-- Note that if the value is not available, the action is not run +-- and instead it prints a message to help the user make the necessary +-- private data available. +withPrivData + :: PrivDataField + -> Context + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) + -> Property +withPrivData field context@(Context cname) mkprop = addinfo $ mkprop $ \a -> + maybe missing a =<< liftIO (getLocalPrivData field context) + where + missing = liftIO $ do + warningMessage $ "Missing privdata " ++ show field ++ " (for " ++ cname ++ ")" + putStrLn $ "Fix this by running: propellor --set '" ++ show field ++ "' '" ++ cname ++ "'" + return FailedChange + addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privDataFields = S.singleton (field, context) } } + +{- Gets the requested field's value, in the specified context if it's + - available, from the host's local privdata cache. -} +getLocalPrivData :: PrivDataField -> Context -> IO (Maybe PrivData) +getLocalPrivData field context = + getPrivData field context . fromMaybe M.empty <$> localcache where - missing = do - host <- asks hostName - 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 ++ "'" - return FailedChange - -getPrivData :: PrivDataField -> IO (Maybe String) -getPrivData field = do - m <- catchDefaultIO Nothing $ readish <$> readFile privDataLocal - return $ maybe Nothing (M.lookup field) m - -setPrivData :: HostName -> PrivDataField -> IO () -setPrivData host field = do + localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal + +getPrivData :: PrivDataField -> Context -> (M.Map (PrivDataField, Context) PrivData) -> Maybe PrivData +getPrivData field context = M.lookup (field, context) + +setPrivData :: PrivDataField -> Context -> IO () +setPrivData field context = do putStrLn "Enter private data on stdin; ctrl-D when done:" - setPrivDataTo host field =<< hGetContentsStrict stdin + setPrivDataTo field context =<< hGetContentsStrict stdin -dumpPrivData :: HostName -> PrivDataField -> IO () -dumpPrivData host field = +dumpPrivData :: PrivDataField -> Context -> IO () +dumpPrivData field context = maybe (error "Requested privdata is not set.") putStrLn - =<< getPrivDataFor host field + =<< (getPrivData field context <$> decryptPrivData) -editPrivData :: HostName -> PrivDataField -> IO () -editPrivData host field = do - v <- getPrivDataFor host field +editPrivData :: PrivDataField -> Context -> IO () +editPrivData field context = do + v <- getPrivData field context <$> decryptPrivData v' <- withTmpFile "propellorXXXX" $ \f h -> do hClose h maybe noop (writeFileProtected f) v @@ -66,35 +85,30 @@ editPrivData host field = do unlessM (boolSystem editor [File f]) $ error "Editor failed; aborting." readFile f - setPrivDataTo host field v' + setPrivDataTo field context v' -listPrivDataFields :: HostName -> IO () -listPrivDataFields host = do - putStrLn (host ++ "'s currently set privdata fields:") - mapM_ list . M.keys =<< decryptPrivData host +listPrivDataFields :: IO () +listPrivDataFields = do + putStrLn ("All currently set privdata fields:") + mapM_ list . M.keys =<< decryptPrivData where list = putStrLn . ("\t" ++) . shellEscape . show -setPrivDataTo :: HostName -> PrivDataField -> String -> IO () -setPrivDataTo host field value = do +setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () +setPrivDataTo field context value = do makePrivDataDir - let f = privDataFile host - m <- decryptPrivData host - let m' = M.insert field (chomp value) m - gpgEncrypt f (show m') + m <- decryptPrivData + let m' = M.insert (field, context) (chomp value) m + gpgEncrypt privDataFile (show m') putStrLn "Private data set." - void $ boolSystem "git" [Param "add", File f] + void $ boolSystem "git" [Param "add", File privDataFile] where chomp s | end s == "\n" = chomp (beginning s) | otherwise = s -getPrivDataFor :: HostName -> PrivDataField -> IO (Maybe String) -getPrivDataFor host field = M.lookup field <$> decryptPrivData host - -decryptPrivData :: HostName -> IO (M.Map PrivDataField String) -decryptPrivData host = fromMaybe M.empty . readish - <$> gpgDecrypt (privDataFile host) +decryptPrivData :: IO (M.Map (PrivDataField, Context) PrivData) +decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir @@ -102,8 +116,8 @@ makePrivDataDir = createDirectoryIfMissing False privDataDir privDataDir :: FilePath privDataDir = "privdata" -privDataFile :: HostName -> FilePath -privDataFile host = privDataDir host ++ ".gpg" +privDataFile :: FilePath +privDataFile = privDataDir "privdata.gpg" privDataLocal :: FilePath privDataLocal = privDataDir "local" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 1521eb65..4d443986 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -55,10 +55,11 @@ installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. configured :: Property -configured = property "docker configured" go `requires` installed +configured = prop `requires` installed where - go = withPrivData DockerAuthentication $ \cfg -> ensureProperty $ - "/root/.dockercfg" `File.hasContent` (lines cfg) + prop = withPrivData DockerAuthentication anyContext $ \getcfg -> + property "docker configured" $ getcfg $ \cfg -> ensureProperty $ + "/root/.dockercfg" `File.hasContent` (lines cfg) -- | A short descriptive name for a container. -- Should not contain whitespace or other unusual characters, diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 0b060177..0e738f25 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -17,16 +17,17 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f) -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: FilePath -> Property -hasPrivContent f = property desc $ withPrivData (PrivFile f) $ \privcontent -> - ensureProperty $ fileProperty' writeFileProtected desc - (\_oldcontent -> lines privcontent) f +hasPrivContent :: FilePath -> Context -> Property +hasPrivContent f context = withPrivData (PrivFile f) context $ \getcontent -> + property desc $ getcontent $ \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` +hasPrivContentExposed :: FilePath -> Context -> Property +hasPrivContentExposed f context = hasPrivContent f context `onChange` mode f (combineModes (ownerWriteMode:readModes)) -- | Ensures that a line is present in a file, adding it to the end if not. diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs index 64ea9fea..b4698663 100644 --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -9,6 +9,8 @@ import System.PosixCompat installed :: Property installed = Apt.installed ["gnupg"] +type GpgKeyId = String + -- | 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, @@ -21,19 +23,20 @@ installed = Apt.installed ["gnupg"] -- 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 +keyImported keyid user = flagFile' prop 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 + prop = withPrivData GpgKey (Context keyid) $ \getkey -> + property desc $ getkey $ \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 diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs index 051d6425..39cb6ff0 100644 --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -25,5 +25,6 @@ providerFor users baseurl = propertyList desc $ -- the identitites directory controls access, so open up -- file mode - identfile u = File.hasPrivContentExposed $ - concat $ [ "/var/lib/simpleid/identities/", u, ".identity" ] + identfile u = File.hasPrivContentExposed + (concat [ "/var/lib/simpleid/identities/", u, ".identity" ]) + (Context baseurl) diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 85584e43..4cb26a50 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -23,29 +23,25 @@ builddir = gitbuilderdir "build" type TimeOut = String -- eg, 5h -autobuilder :: CronTimes -> TimeOut -> Bool -> Property -autobuilder crontimes timeout rsyncupload = combineProperties "gitannexbuilder" +autobuilder :: Architecture -> CronTimes -> TimeOut -> Property +autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" [ Apt.serviceInstalledRunning "cron" , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ "git pull ; timeout " ++ timeout ++ " ./autobuild" -- 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 - let f = homedir "rsyncpassword" - if rsyncupload - then withPrivData (Password builduser) $ \p -> do - oldp <- liftIO $ catchDefaultIO "" $ - readFileStrict f - if p /= oldp - then makeChange $ writeFile f p - else noChange - else do - ifM (liftIO $ doesFileExist f) - ( noChange - , makeChange $ writeFile f "no password configured" - ) + , withPrivData (Password builduser) context $ \getpw -> + property "rsync password" $ getpw $ \pw -> do + oldpw <- liftIO $ catchDefaultIO "" $ + readFileStrict pwfile + if pw /= oldpw + then makeChange $ writeFile pwfile pw + else noChange ] + where + context = Context ("gitannexbuilder " ++ arch) + pwfile = homedir "rsyncpassword" tree :: Architecture -> Property tree buildarch = combineProperties "gitannexbuilder tree" @@ -101,13 +97,13 @@ standardAutoBuilderContainer dockerImage arch buildminute timeout = Docker.conta & User.accountFor builduser & tree arch & buildDepsApt - & autobuilder (show buildminute ++ " * * * *") timeout True + & autobuilder arch (show buildminute ++ " * * * *") timeout androidAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host androidAutoBuilderContainer dockerImage crontimes timeout = androidContainer dockerImage "android-git-annex-builder" (tree "android") builddir & Apt.unattendedUpgrades - & autobuilder crontimes timeout True + & autobuilder "android" crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Host @@ -154,7 +150,7 @@ armelCompanionContainer dockerImage = Docker.container "armel-git-annex-builder- -- The armel builder can ssh to this companion. & Docker.expose "22" & Apt.serviceInstalledRunning "ssh" - & Ssh.authorizedKeys builduser + & Ssh.authorizedKeys builduser (Context "armel-git-annex-builder") armelAutoBuilderContainer :: (System -> Docker.Image) -> Cron.CronTimes -> TimeOut -> Host armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "armel-git-annex-builder" @@ -172,9 +168,9 @@ armelAutoBuilderContainer dockerImage crontimes timeout = Docker.container "arme -- git-annex/standalone/linux/install-haskell-packages -- which is not fully automated.) & buildDepsNoHaskellLibs - & autobuilder crontimes timeout True + & autobuilder "armel" crontimes timeout `requires` tree "armel" - & Ssh.keyImported SshRsa builduser + & Ssh.keyImported SshRsa builduser (Context "armel-git-annex-builder") & trivial writecompanionaddress where writecompanionaddress = scriptProperty diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 57023cb5..bffc8a30 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -29,7 +29,7 @@ oldUseNetServer hosts = propertyList ("olduse.net server") [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" , "--client-name=spool" ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ property "olduse.net spool in place" $ makeChange $ do @@ -97,7 +97,7 @@ 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" + , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext `onChange` Service.restarted "kgb-bot" , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" `describe` "kgb bot enabled" @@ -108,17 +108,19 @@ kgbServer = withOS desc $ \o -> case o of desc = "kgb.kitenet.net setup" mumbleServer :: [Host] -> Property -mumbleServer hosts = combineProperties "mumble.debian.net" +mumbleServer hosts = combineProperties hn [ Apt.serviceInstalledRunning "mumble-server" , Obnam.latestVersion , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" - [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/mumble.debian.net.obnam" + [ "--repository=sftp://joey@turtle.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" , "--client-name=mumble" ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.keyImported SshRsa "root" (Context hn) `requires` Ssh.knownHost hosts "turtle.kitenet.net" "root" , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] ] + where + hn = "mumble.debian.net" obnamLowMem :: Property obnamLowMem = combineProperties "obnam tuned for low memory use" @@ -141,16 +143,16 @@ gitServer hosts = propertyList "git.kitenet.net setup" , "--client-name=wren" ] Obnam.OnlyClient `requires` Gpg.keyImported "1B169BE1" "root" - `requires` Ssh.keyImported SshRsa "root" + `requires` Ssh.keyImported SshRsa "root" (Context "git.kitenet.net") `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - `requires` Ssh.authorizedKeys "family" + `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") `requires` User.accountFor "family" , Apt.installed ["git", "rsync", "gitweb"] -- backport avoids channel flooding on branch merge , Apt.installedBackport ["kgb-client"] -- backport supports ssh event notification , Apt.installedBackport ["git-annex"] - , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" + , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext , toProp $ Git.daemonRunning "/srv/git" , "/etc/gitweb.conf" `File.containsLines` [ "$projectroot = '/srv/git';" @@ -202,7 +204,7 @@ annexWebSite hosts origin hn uuid remotes = propertyList (hn ++" website using g dir = "/srv/web/" ++ hn postupdatehook = dir ".git/hooks/post-update" setup = userScriptProperty "joey" setupscript - `requires` Ssh.keyImported SshRsa "joey" + `requires` Ssh.keyImported SshRsa "joey" (Context hn) `requires` Ssh.knownHost hosts "turtle.kitenet.net" "joey" setupscript = [ "cd " ++ shellEscape dir @@ -270,9 +272,9 @@ mainhttpscert True = gitAnnexDistributor :: Property gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" [ Apt.installed ["rsync"] - , File.hasPrivContent "/etc/rsyncd.conf" + , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , File.hasPrivContent "/etc/rsyncd.secrets" + , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") `onChange` Service.restarted "rsync" , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" `onChange` Service.running "rsync" @@ -315,7 +317,7 @@ ircBouncer = propertyList "IRC bouncer" [ Apt.installed ["znc"] , User.accountFor "znc" , File.dirExists (parentDir conf) - , File.hasPrivContent conf + , File.hasPrivContent conf anyContext , File.ownerGroup conf "znc" "znc" , Cron.job "znconboot" "@reboot" "znc" "~" "znc" -- ensure running if it was not already @@ -341,7 +343,7 @@ githubBackup :: Property githubBackup = propertyList "github-backup box" [ Apt.installed ["github-backup", "moreutils"] , let f = "/home/joey/.github-keys" - in File.hasPrivContent f + in File.hasPrivContent f anyContext `onChange` File.ownerGroup f "joey" "joey" ] diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index bc0e7cab..6785ede6 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -75,42 +75,43 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /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 "") "") +-- | Sets ssh host keys. +hostKey :: SshKeyType -> Context -> Property +hostKey keytype context = combineProperties desc + [ installkey (SshPubKey keytype "") (install writeFile ".pub") + , installkey (SshPrivKey keytype "") (install writeFileProtected "") ] `onChange` restartSshd where desc = "known ssh host key (" ++ fromKeyType keytype ++ ")" - install writer p ext = withPrivData p $ \key -> do + installkey p a = withPrivData p context $ \getkey -> + property desc $ getkey a + install writer ext 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) "") +-- | Sets up a user with a ssh private key and public key pair from the +-- PrivData. +keyImported :: SshKeyType -> UserName -> Context -> Property +keyImported keytype user context = combineProperties desc + [ installkey (SshPubKey keytype user) (install writeFile ".pub") + , installkey (SshPrivKey keytype user) (install writeFileProtected "") ] where desc = user ++ " has ssh key (" ++ fromKeyType keytype ++ ")" - install writer p ext = do + installkey p a = withPrivData p context $ \getkey -> + property desc $ getkey a + install writer ext key = do f <- liftIO $ keyfile ext ifM (liftIO $ doesFileExist f) ( noChange , ensureProperties - [ property desc $ - withPrivData p $ \key -> makeChange $ do - createDirectoryIfMissing True (takeDirectory f) - writer f key + [ property desc $ makeChange $ do + createDirectoryIfMissing True (takeDirectory f) + writer f key , File.ownerGroup f user user , File.ownerGroup (takeDirectory f) user user ] @@ -143,9 +144,9 @@ knownHost hosts hn user = property desc $ 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 +authorizedKeys :: UserName -> Context -> Property +authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> + property (user ++ " has authorized_keys") $ get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user liftIO $ do createDirectoryIfMissing True (takeDirectory f) diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index eef2a57e..f9c400a8 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -24,17 +24,18 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use -- | 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 - -hasPassword :: UserName -> Property -hasPassword user = property (user ++ " has password") $ - withPrivData (Password user) $ \password -> makeChange $ - withHandle StdinHandle createProcessSuccess - (proc "chpasswd" []) $ \h -> do - hPutStrLn h $ user ++ ":" ++ password - hClose h +hasSomePassword :: UserName -> Context -> Property +hasSomePassword user context = check ((/= HasPassword) <$> getPasswordStatus user) $ + hasPassword user context + +hasPassword :: UserName -> Context -> Property +hasPassword user context = withPrivData (Password user) context $ \getpassword -> + property (user ++ " has password") $ + getpassword $ \password -> makeChange $ + withHandle StdinHandle createProcessSuccess + (proc "chpasswd" []) $ \h -> do + hPutStrLn h $ user ++ ":" ++ password + hClose h lockedPassword :: UserName -> Property lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 59652f66..037cd962 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -17,7 +17,9 @@ module Propellor.Types , ActionResult(..) , CmdLine(..) , PrivDataField(..) - , GpgKeyId + , PrivData + , Context(..) + , anyContext , SshKeyType(..) , module Propellor.Types.OS , module Propellor.Types.Dns @@ -32,6 +34,7 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns +import Propellor.Types.PrivData -- | Everything Propellor knows about a system: Its hostname, -- properties and other info. @@ -135,30 +138,12 @@ data CmdLine = Run HostName | Spin HostName | Boot HostName - | Set HostName PrivDataField - | Dump HostName PrivDataField - | Edit HostName PrivDataField - | ListFields HostName + | Set PrivDataField Context + | Dump PrivDataField Context + | Edit PrivDataField Context + | ListFields | AddKey String | Continue CmdLine | Chain HostName | Docker HostName deriving (Read, Show, Eq) - --- | Note that removing or changing field names will break the --- serialized privdata files, so don't do that! --- It's fine to add new fields. -data PrivDataField - = DockerAuthentication - | 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 | SshEd25519 - deriving (Read, Show, Ord, Eq) diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index 5f034492..8856e06f 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -1,6 +1,7 @@ module Propellor.Types.Info where import Propellor.Types.OS +import Propellor.Types.PrivData import qualified Propellor.Types.Dns as Dns import qualified Data.Set as S @@ -9,6 +10,7 @@ import Data.Monoid -- | Information about a host. data Info = Info { _os :: Val System + , _privDataFields :: S.Set (PrivDataField, Context) , _sshPubKey :: Val String , _dns :: S.Set Dns.Record , _namedconf :: Dns.NamedConfMap @@ -17,9 +19,10 @@ data Info = Info deriving (Eq, Show) instance Monoid Info where - mempty = Info mempty mempty mempty mempty mempty + mempty = Info mempty mempty mempty mempty mempty mempty mappend old new = Info { _os = _os old <> _os new + , _privDataFields = _privDataFields old <> _privDataFields new , _sshPubKey = _sshPubKey old <> _sshPubKey new , _dns = _dns old <> _dns new , _namedconf = _namedconf old <> _namedconf new diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs new file mode 100644 index 00000000..16d6cdb1 --- /dev/null +++ b/src/Propellor/Types/PrivData.hs @@ -0,0 +1,34 @@ +module Propellor.Types.PrivData where + +import Propellor.Types.OS + +-- | Note that removing or changing field names will break the +-- serialized privdata files, so don't do that! +-- It's fine to add new fields. +data PrivDataField + = DockerAuthentication + | SshPubKey SshKeyType UserName + | SshPrivKey SshKeyType UserName + | SshAuthorizedKeys UserName + | Password UserName + | PrivFile FilePath + | GpgKey + deriving (Read, Show, Ord, Eq) + +-- | Context in which a PrivDataField is used. +-- +-- Often this will be a domain name. For example, +-- Context "www.example.com" could be used for the SSL cert +-- for the web server serving that domain. Multiple hosts might +-- use that privdata. +newtype Context = Context String + deriving (Read, Show, Ord, Eq) + +-- | Use when a PrivDataField is not dependent on any paricular context. +anyContext :: Context +anyContext = Context "any" + +type PrivData = String + +data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519 + deriving (Read, Show, Ord, Eq) -- cgit v1.2.3