summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/CmdLine.hs38
-rw-r--r--src/Propellor/PrivData.hs151
-rw-r--r--src/Propellor/Property/Docker.hs24
-rw-r--r--src/Propellor/Property/File.hs13
-rw-r--r--src/Propellor/Property/Gpg.hs17
-rw-r--r--src/Propellor/Property/Hostname.hs26
-rw-r--r--src/Propellor/Property/OpenId.hs5
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs38
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs59
-rw-r--r--src/Propellor/Property/Ssh.hs52
-rw-r--r--src/Propellor/Property/User.hs23
-rw-r--r--src/Propellor/Types.hs29
-rw-r--r--src/Propellor/Types/Info.hs5
-rw-r--r--src/Propellor/Types/PrivData.hs34
-rw-r--r--src/Utility/Table.hs28
15 files changed, 348 insertions, 194 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 32e97316..448e70d2 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -26,9 +26,11 @@ usage = do
, " propellor"
, " propellor hostname"
, " propellor --spin hostname"
- , " propellor --set hostname field"
- , " propellor --dump hostname field"
, " propellor --add-key keyid"
+ , " propellor --set field context"
+ , " propellor --dump field context"
+ , " propellor --edit field context"
+ , " propellor --list-fields"
]
exitFailure
@@ -39,8 +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 ("--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"
@@ -56,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 ()
@@ -69,8 +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 _ (Set field context) = setPrivData field context
+ go _ (Dump field context) = dumpPrivData field context
+ go _ (Edit field context) = editPrivData field context
+ go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
go _ (Chain hn) = withhost hn $ \h -> do
r <- runPropellor h $ ensureProperties $ hostProperties h
@@ -78,7 +84,7 @@ defaultMain hostlist = do
go _ (Docker hn) = Docker.chain hn
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
- go False (Spin hn) = withhost hn $ const $ spin hn
+ go False (Spin hn) = withhost hn $ spin hn
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withhost hn mainProperties
, go True (Spin hn)
@@ -170,17 +176,19 @@ updateFirst cmdline next = do
getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-spin :: HostName -> IO ()
-spin hn = do
+spin :: HostName -> Host -> IO ()
+spin hn hst = do
url <- getUrl
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 =<< hostprivdata
where
+ hostprivdata = show . filterPrivData hst <$> decryptPrivData
+
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 "privdata" privDataMarker privdata
hClose toh
-- Display remaining output.
@@ -222,8 +230,8 @@ spin hn = do
Just status -> return status
showremote s = putStrLn s
- senddata toh f marker s = void $
- actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
+ senddata toh desc marker s = void $
+ actionMessage ("Sending " ++ desc ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
sendMarked toh marker s
return True
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 5ddbdcff..d7d81a21 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -2,18 +2,23 @@
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.Monoid
import Data.List
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 Propellor.Info
import Utility.Monad
import Utility.PartialPrelude
import Utility.Exception
@@ -21,53 +26,119 @@ import Utility.Process
import Utility.Tmp
import Utility.SafeCommand
import Utility.Misc
+import Utility.FileMode
+import Utility.Env
+import Utility.Table
+
+type PrivMap = M.Map (PrivDataField, Context) PrivData
--- | 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.
+--
+-- The resulting Property includes Info about the PrivDataField
+-- being used, which is necessary to ensure that the privdata is sent to
+-- the remote host by propellor.
+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 = 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
+ 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) } }
+
+addPrivDataField :: (PrivDataField, Context) -> Property
+addPrivDataField v = pureInfoProperty (show v) $
+ mempty { _privDataFields = S.singleton v }
+
+{- 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
+ localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal
+
+{- Get only the set of PrivData that the Host's Info says it uses. -}
+filterPrivData :: Host -> PrivMap -> PrivMap
+filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
+ where
+ used = _privDataFields $ hostInfo host
+
+getPrivData :: PrivDataField -> Context -> PrivMap -> 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:"
- value <- chomp <$> hGetContentsStrict stdin
+ setPrivDataTo field context =<< hGetContentsStrict stdin
+
+dumpPrivData :: PrivDataField -> Context -> IO ()
+dumpPrivData field context =
+ maybe (error "Requested privdata is not set.") putStrLn
+ =<< (getPrivData field context <$> decryptPrivData)
+
+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
+ editor <- getEnvDefault "EDITOR" "vi"
+ unlessM (boolSystem editor [File f]) $
+ error "Editor failed; aborting."
+ readFile f
+ setPrivDataTo field context v'
+
+listPrivDataFields :: [Host] -> IO ()
+listPrivDataFields hosts = do
+ m <- decryptPrivData
+ putStrLn "\n"
+ let usedby = M.unionsWith (++) $ map mkhostmap hosts
+ let rows = map (mkrow usedby) (M.keys m)
+ let table = tableWithHeader header rows
+ putStr $ unlines $ formatTable table
+ where
+ header = ["Field", "Context", "Used by"]
+ mkrow usedby k@(field, (Context context)) =
+ [ shellEscape $ show field
+ , shellEscape context
+ , intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
+ ]
+ mkhostmap host = M.fromList $ map (\k -> (k, [hostName host])) $
+ S.toList $ _privDataFields $ hostInfo host
+
+setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
+setPrivDataTo field context value = do
makePrivDataDir
- let f = privDataFile host
- m <- decryptPrivData host
- let m' = M.insert field 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
-dumpPrivData :: HostName -> PrivDataField -> IO ()
-dumpPrivData host field = go . M.lookup field =<< decryptPrivData host
- where
- go Nothing = error "Requested privdata is not set."
- go (Just s) = putStrLn s
-
-decryptPrivData :: HostName -> IO (M.Map PrivDataField String)
-decryptPrivData host = fromMaybe M.empty . readish
- <$> gpgDecrypt (privDataFile host)
+decryptPrivData :: IO PrivMap
+decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile
makePrivDataDir :: IO ()
makePrivDataDir = createDirectoryIfMissing False privDataDir
@@ -75,8 +146,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..4307b850 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,
@@ -86,8 +87,8 @@ cn2hn cn = cn ++ ".docker"
-- The container has its own Properties which are handled by running
-- propellor inside the container.
--
--- Additionally, the container can have DNS info, such as a CNAME.
--- These become info of the host(s) it's docked in.
+-- When the container's Properties include DNS info, such as a CNAME,
+-- that is propigated to the Info of the host(s) it's docked in.
--
-- Reverting this property ensures that the container is stopped and
-- removed.
@@ -96,7 +97,7 @@ docked
-> ContainerName
-> RevertableProperty
docked hosts cn = RevertableProperty
- ((maybe id exposeDnsInfos mhost) (go "docked" setup))
+ ((maybe id propigateInfo mhost) (go "docked" setup))
(go "undocked" teardown)
where
go desc a = property (desc ++ " " ++ cn) $ do
@@ -123,9 +124,12 @@ docked hosts cn = RevertableProperty
]
]
-exposeDnsInfos :: Host -> Property -> Property
-exposeDnsInfos (Host _ _ containerinfo) p = combineProperties (propertyDesc p) $
- p : map addDNS (S.toList $ _dns containerinfo)
+propigateInfo :: Host -> Property -> Property
+propigateInfo (Host _ _ containerinfo) p =
+ combineProperties (propertyDesc p) $ p : dnsprops ++ privprops
+ where
+ dnsprops = map addDNS (S.toList $ _dns containerinfo)
+ privprops = map addPrivDataField (S.toList $ _privDataFields containerinfo)
findContainer
:: Maybe Host
@@ -390,7 +394,7 @@ chain s = case toContainerId s of
-- being run. So, retry connections to the client for up to
-- 1 minute.
provisionContainer :: ContainerId -> Property
-provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
+provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
r <- simpleShClientRetry 60 (namedPipe cid) shim params (go Nothing)
when (r /= FailedChange) $
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/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 10fda040..1cce4e60 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -3,11 +3,16 @@ module Propellor.Property.Hostname where
import Propellor
import qualified Propellor.Property.File as File
--- | Ensures that the hostname is set to the HostInfo value.
+-- | Ensures that the hostname is set using best practices.
+--
-- Configures /etc/hostname and the current hostname.
--
--- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is
--- standard at least on Debian to set the FDQN (127.0.0.1 is localhost).
+-- /etc/hosts is also configured, with an entry for 127.0.1.1, which is
+-- standard at least on Debian to set the FDQN.
+--
+-- Also, the /etc/hosts 127.0.0.1 line is set to localhost. Putting any
+-- other hostnames there is not best practices and can lead to annoying
+-- messages from eg, apache.
sane :: Property
sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName)
@@ -21,13 +26,14 @@ setTo hn = combineProperties desc go
[ Just $ "/etc/hostname" `File.hasContent` [basehost]
, if null domain
then Nothing
- else Just $ File.fileProperty desc
- addhostline "/etc/hosts"
+ else Just $ trivial $ hostsline "127.0.1.1" [hn, basehost]
+ , Just $ trivial $ hostsline "127.0.0.1" ["localhost"]
, Just $ trivial $ cmdProperty "hostname" [basehost]
]
- hostip = "127.0.1.1"
- hostline = hostip ++ "\t" ++ hn ++ " " ++ basehost
-
- addhostline ls = hostline : filter (not . hashostip) ls
- hashostip l = headMaybe (words l) == Just hostip
+ hostsline ip names = File.fileProperty desc
+ (addhostsline ip names)
+ "/etc/hosts"
+ addhostsline ip names ls =
+ (ip ++ "\t" ++ (unwords names)) : filter (not . hasip ip) ls
+ hasip ip l = headMaybe (words l) == Just ip
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 120ea611..c770907b 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -16,6 +16,7 @@ import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Apache as Apache
import Utility.SafeCommand
import Utility.FileMode
+import Utility.Path
import Data.List
import System.Posix.Files
@@ -28,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
@@ -84,37 +85,44 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
, "dpkg -i ../" ++ pkg ++ "_*.deb || true"
, "apt-get -fy install" -- dependencies
, "rm -rf /root/tmp/oldusenet"
+ -- screen fails unless the directory has this mode.
+ -- not sure what's going on.
+ , "chmod 777 /var/run/screen"
] `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+)"
+kgbServer = propertyList desc
+ [ withOS desc $ \o -> case o of
+ (Just (System (Debian Unstable) _)) ->
+ ensureProperty $ propertyList desc
+ [ Apt.serviceInstalledRunning "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+)"
+ , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
+ `onChange` Service.restarted "kgb-bot"
+ ]
where
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"
@@ -137,16 +145,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';"
@@ -198,7 +206,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
@@ -266,9 +274,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"
@@ -310,10 +318,13 @@ ircBouncer :: Property
ircBouncer = propertyList "IRC bouncer"
[ Apt.installed ["znc"]
, User.accountFor "znc"
- , File.hasPrivContent conf
+ , File.dirExists (parentDir conf)
+ , File.hasPrivContent conf anyContext
, File.ownerGroup conf "znc" "znc"
, Cron.job "znconboot" "@reboot" "znc" "~" "znc"
- , Cron.job "zncrunning" "@hourly" "znc" "~" "znc || true"
+ -- ensure running if it was not already
+ , trivial $ userScriptProperty "znc" ["znc || true"]
+ `describe` "znc running"
]
where
conf = "/home/znc/.znc/configs/znc.conf"
@@ -335,7 +346,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 061f440c..6785ede6 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -72,46 +72,46 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
[ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*"
]
- 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 "") "")
+ ensureProperty $ scriptProperty
+ [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
+
+-- | 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
]
@@ -144,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 383797a9..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,28 +138,12 @@ data CmdLine
= Run HostName
| Spin HostName
| Boot HostName
- | Set HostName PrivDataField
- | Dump HostName PrivDataField
+ | 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)
diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs
new file mode 100644
index 00000000..910038e8
--- /dev/null
+++ b/src/Utility/Table.hs
@@ -0,0 +1,28 @@
+{- text based table generation
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Table where
+
+type Table = [[String]]
+
+-- | A table with a header that is set off with lines under each
+-- header item.
+tableWithHeader :: [String] -> [[String]] -> Table
+tableWithHeader header rows = header : map linesep header : rows
+ where
+ linesep = map (const '-')
+
+-- | Formats a table to lines, automatically padding rows to the same size.
+formatTable :: Table -> [String]
+formatTable table = map (\r -> unwords (map pad (zip r rowsizes))) table
+ where
+ pad (cell, size) = cell ++ take (size - length cell) padding
+ padding = repeat ' '
+ rowsizes = sumrows (map (map length) table)
+ sumrows [] = repeat 0
+ sumrows [r] = r
+ sumrows (r1:r2:rs) = sumrows $ map (uncurry max) (zip r1 r2) : rs