propellor spin
This commit is contained in:
Joey Hess
parent
c7830f4e66
commit
c97285a21e
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -74,13 +74,12 @@ hosts =
|
|||
& Git.daemonRunning "/srv/git"
|
||||
& File.ownerGroup "/srv/git" "joey" "joey"
|
||||
& Obnam.backup "/srv/git" "33 3 * * *"
|
||||
[ "--repository=2318@usw-s002.rsync.net:git.kitenet.net"
|
||||
[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net.obnam"
|
||||
, "--encrypt-with=1B169BE1"
|
||||
]
|
||||
] Obnam.OnlyClient
|
||||
`requires` Gpg.keyImported "1B169BE1" "root"
|
||||
`requires` Ssh.keyImported SshRsa "root"
|
||||
|
||||
-- git repos restore (how?) (also make backups!)
|
||||
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root"
|
||||
-- family annex needs family members to have accounts,
|
||||
-- ssh host key etc.. finesse?
|
||||
-- (also should upgrade git-annex-shell for it..)
|
||||
|
|
@ -89,6 +88,10 @@ hosts =
|
|||
-- gitweb
|
||||
-- downloads.kitenet.net setup (including ssh key to turtle)
|
||||
|
||||
-- I don't run this system, but tell propellor its public key.
|
||||
, host "usw-s002.rsync.net"
|
||||
& sshPubKey "ssh-dss AAAAB3NzaC1kc3MAAAEBAI6ZsoW8a+Zl6NqUf9a4xXSMcV1akJHDEKKBzlI2YZo9gb9YoCf5p9oby8THUSgfh4kse7LJeY7Nb64NR6Y/X7I2/QzbE1HGGl5mMwB6LeUcJ74T3TQAlNEZkGt/MOIVLolJHk049hC09zLpkUDtX8K0t1yaCirC9SxDGLTCLEhvU9+vVdVrdQlKZ9wpLUNbdAzvbra+O/IVvExxDZ9WCHrnfNA8ddVZIGEWMqsoNgiuCxiXpi8qL+noghsSQNFTXwo7W2Vp9zj1JkCt3GtSz5IzEpARQaXEAWNEM0n1nJ686YUOhou64iRM8bPC1lp3QXvvZNgj3m+QHhIempx+de8AAAAVAKB5vUDaZOg14gRn7Bp81ja/ik+RAAABACPH/bPbW912x1NxNiikzGR6clLh+bLpIp8Qie3J7DwOr8oC1QOKjNDK+UgQ7mDQEgr4nGjNKSvpDi4c1QCw4sbLqQgx1y2VhT0SmUPHf5NQFldRQyR/jcevSSwOBxszz3aq9AwHiv9OWaO3XY18suXPouiuPTpIcZwc2BLDNHFnDURQeGEtmgqj6gZLIkTY0iw7q9Tj5FOyl4AkvEJC5B4CSzaWgey93Wqn1Imt7KI8+H9lApMKziVL1q+K7xAuNkGmx5YOSNlE6rKAPtsIPHZGxR7dch0GURv2jhh0NQYvBRn3ukCjuIO5gx56HLgilq59/o50zZ4NcT7iASF76TcAAAEAC6YxX7rrs8pp13W4YGiJHwFvIO1yXLGOdqu66JM0plO4J1ItV1AQcazOXLiliny3p2/W+wXZZKd5HIRt52YafCA8YNyMk/sF7JcTR4d4z9CfKaAxh0UpzKiAk+0j/Wu3iPoTOsyt7N0j1+dIyrFodY2sKKuBMT4TQ0yqQpbC+IDQv2i1IlZAPneYGfd5MIGygs2QMfaMQ1jWAKJvEO0vstZ7GB6nDAcg4in3ZiBHtomx3PL5w+zg48S4Ed69BiFXLZ1f6MnjpUOP75pD4MP6toS0rgK9b93xCrEQLgm4oD/7TCHHBo2xR7wwcsN2OddtwWsEM2QgOkt/jdCAoVCqwQ=="
|
||||
|
||||
--' __|II| ,.
|
||||
---- __|II|II|__ ( \_,/\
|
||||
------'\o/-'-.-'-.-'-.- __|II|II|II|II|___/ __/ -'-.-'-.-'-.-'-.-'-
|
||||
|
|
|
|||
Loading…
Reference in New Issue