summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-09-14 20:23:08 -0400
committerJoey Hess2015-09-14 20:23:08 -0400
commite5c398a0f6dfc65d56c2dcdf2e8bbf031579ef38 (patch)
treec76125aaf059f4acaab6a32c3cfc223e5294c787 /src
parent0f9f05ae9e65182daa9bfc98a9932e2e1382e9b5 (diff)
parentfb7b1826870c8a0e01f88da74ff2fd98a0626d5b (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Info.hs2
-rw-r--r--src/Propellor/Message.hs3
-rw-r--r--src/Propellor/PrivData.hs28
-rw-r--r--src/Propellor/PropAccum.hs2
-rw-r--r--src/Propellor/Property.hs3
-rw-r--r--src/Propellor/Property/Apt.hs27
-rw-r--r--src/Propellor/Property/ConfFile.hs3
-rw-r--r--src/Propellor/Property/Debootstrap.hs2
-rw-r--r--src/Propellor/Property/DiskImage.hs12
-rw-r--r--src/Propellor/Property/Dns.hs6
-rw-r--r--src/Propellor/Property/Docker.hs11
-rw-r--r--src/Propellor/Property/File.hs4
-rw-r--r--src/Propellor/Property/Gpg.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs7
-rw-r--r--src/Propellor/Property/SiteSpecific/IABak.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs25
-rw-r--r--src/Propellor/Property/Tor.hs4
-rw-r--r--src/Propellor/Property/Unbound.hs87
-rw-r--r--src/Propellor/Property/User.hs4
-rw-r--r--src/Propellor/Shim.hs2
-rw-r--r--src/Propellor/Spin.hs6
-rw-r--r--src/Propellor/Types.hs2
-rw-r--r--src/Propellor/Types/Container.hs4
-rw-r--r--src/Propellor/Types/PrivData.hs21
-rw-r--r--src/Utility/Exception.hs21
-rw-r--r--src/Utility/Misc.hs2
-rw-r--r--src/Utility/Process.hs46
-rw-r--r--src/Utility/Scheduled.hs2
-rw-r--r--src/Utility/Table.hs2
29 files changed, 237 insertions, 105 deletions
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index b9436e58..74614a1b 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -87,7 +87,7 @@ aliasMap = M.fromList . concat .
map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)
findHost :: [Host] -> HostName -> Maybe Host
-findHost l hn = maybe (findAlias l hn) Just (findHostNoAlias l hn)
+findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)
findHostNoAlias :: [Host] -> HostName -> Maybe Host
findHostNoAlias l hn = M.lookup hn (hostMap l)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index f62d3cd9..94892da8 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -112,8 +112,7 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
go (Just "1") = enableDebugMode
go (Just _) = noop
go Nothing = whenM (doesDirectoryExist ".git") $
- whenM (any (== "1") . lines <$> getgitconfig) $
- enableDebugMode
+ whenM (elem "1" . lines <$> getgitconfig) enableDebugMode
getgitconfig = catchDefaultIO "" $
readProcess "git" ["config", "propellor.debug"]
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 9aa6f380..b7932518 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -132,7 +132,7 @@ getLocalPrivData field context =
where
localcache = catchDefaultIO Nothing $ readish <$> readFile privDataLocal
-type PrivMap = M.Map (PrivDataField, Context) PrivData
+type PrivMap = M.Map (PrivDataField, Context) String
-- | Get only the set of PrivData that the Host's Info says it uses.
filterPrivData :: Host -> PrivMap -> PrivMap
@@ -142,12 +142,14 @@ filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
fromPrivInfo $ getInfo $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
-getPrivData field context = M.lookup (field, context)
+getPrivData field context m = do
+ s <- M.lookup (field, context) m
+ return (PrivData s)
setPrivData :: PrivDataField -> Context -> IO ()
setPrivData field context = do
putStrLn "Enter private data on stdin; ctrl-D when done:"
- setPrivDataTo field context =<< hGetContentsStrict stdin
+ setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin
unsetPrivData :: PrivDataField -> Context -> IO ()
unsetPrivData field context = do
@@ -156,7 +158,8 @@ unsetPrivData field context = do
dumpPrivData :: PrivDataField -> Context -> IO ()
dumpPrivData field context =
- maybe (error "Requested privdata is not set.") putStrLn
+ maybe (error "Requested privdata is not set.")
+ (mapM_ putStrLn . privDataLines)
=<< (getPrivData field context <$> decryptPrivData)
editPrivData :: PrivDataField -> Context -> IO ()
@@ -164,11 +167,11 @@ editPrivData field context = do
v <- getPrivData field context <$> decryptPrivData
v' <- withTmpFile "propellorXXXX" $ \f h -> do
hClose h
- maybe noop (writeFileProtected f) v
+ maybe noop (writeFileProtected f . unlines . privDataLines) v
editor <- getEnvDefault "EDITOR" "vi"
unlessM (boolSystem editor [File f]) $
error "Editor failed; aborting."
- readFile f
+ PrivData <$> readFile f
setPrivDataTo field context v'
listPrivDataFields :: [Host] -> IO ()
@@ -187,29 +190,26 @@ listPrivDataFields hosts = do
showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing
where
header = ["Field", "Context", "Used by"]
- mkrow k@(field, (Context context)) =
+ mkrow k@(field, Context context) =
[ shellEscape $ show field
, shellEscape context
, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
]
mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
S.toList $ fromPrivInfo $ getInfo $ hostInfo host
- usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
+ usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const [hostName h]) hosts
wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
- descmap = M.unions $ map (\h -> mkhostmap h id) hosts
+ descmap = M.unions $ map (`mkhostmap` id) hosts
section desc = putStrLn $ "\n" ++ desc
showtable rows = do
putStr $ unlines $ formatTable $ tableWithHeader header rows
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
-setPrivDataTo field context value = do
+setPrivDataTo field context (PrivData value) = do
modifyPrivData set
putStrLn "Private data set."
where
- set = M.insert (field, context) (chomp value)
- chomp s
- | end s == "\n" = chomp (beginning s)
- | otherwise = s
+ set = M.insert (field, context) value
modifyPrivData :: (PrivMap -> PrivMap) -> IO ()
modifyPrivData f = do
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index d2736b50..4b2a5ddb 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -48,7 +48,7 @@ class PropAccum h where
instance PropAccum Host where
(Host hn ps is) & p = Host hn (ps ++ [toProp p])
(is <> getInfoRecursive p)
- (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)
+ (Host hn ps is) &^ p = Host hn (toProp p : ps)
(getInfoRecursive p <> is)
getProperties = hostProperties
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index b90d5b86..e8d70a80 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -67,8 +67,7 @@ onChangeFlagOnFail
-> Property x
-> Property y
-> CombinedType (Property x) (Property y)
-onChangeFlagOnFail flagfile p1 p2 =
- combineWith go p1 p2
+onChangeFlagOnFail flagfile = combineWith go
where
go s1 s2 = do
r1 <- s1
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 81005f1a..2e913540 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -80,7 +80,7 @@ securityUpdates suite
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
stdSourcesList :: Property NoInfo
-stdSourcesList = withOS ("standard sources.list") $ \o ->
+stdSourcesList = withOS "standard sources.list" $ \o ->
case o of
(Just (System (Debian suite) _)) ->
ensureProperty $ stdSourcesListFor suite
@@ -187,7 +187,7 @@ robustly p = adjustPropertySatisfy p $ \satisfy -> do
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
l <- isInstalled' ps
- return $ any (== False) l && not (null l)
+ return $ elem False l && not (null l)
isInstalled :: Package -> IO Bool
isInstalled p = (== [True]) <$> isInstalled' [p]
@@ -197,7 +197,7 @@ isInstalled p = (== [True]) <$> isInstalled' [p]
-- even vary. If apt does not know about a package at all, it will not
-- be included in the result list.
isInstalled' :: [Package] -> IO [Bool]
-isInstalled' ps = catMaybes . map parse . lines <$> policy
+isInstalled' ps = (mapMaybe parse . lines) <$> policy
where
parse l
| "Installed: (none)" `isInfixOf` l = Just False
@@ -239,18 +239,25 @@ unattendedUpgrades = enable <!> disable
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
_ -> noChange
+type DebconfTemplate = String
+type DebconfTemplateType = String
+type DebconfTemplateValue = String
+
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(String, String, String)] -> Property NoInfo
+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo
reConfigure package vals = reconfigure `requires` setselections
`describe` ("reconfigure " ++ package)
where
- setselections = property "preseed" $ makeChange $
- withHandle StdinHandle createProcessSuccess
- (proc "debconf-set-selections" []) $ \h -> do
- forM_ vals $ \(tmpl, tmpltype, value) ->
- hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
- hClose h
+ setselections = property "preseed" $
+ if null vals
+ then noChange
+ else makeChange $
+ withHandle StdinHandle createProcessSuccess
+ (proc "debconf-set-selections" []) $ \h -> do
+ forM_ vals $ \(tmpl, tmpltype, value) ->
+ hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
+ hClose h
reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv
-- | Ensures that a service is installed and running.
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index 066848bb..0bc1b76d 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -38,8 +38,7 @@ adjustSection
-> InsertSection
-> FilePath
-> Property NoInfo
-adjustSection desc start past adjust insert f =
- fileProperty desc go f
+adjustSection desc start past adjust insert = fileProperty desc go
where
go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls
in if null wanted
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index a46451ef..2551d679 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -158,7 +158,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
let indexfile = tmpd </> "index.html"
unlessM (download baseurl indexfile) $
errorMessage $ "Failed to download " ++ baseurl
- urls <- reverse . sort -- highest version first
+ urls <- sortBy (flip compare) -- highest version first
. filter ("debootstrap_" `isInfixOf`)
. filter (".tar." `isInfixOf`)
. extractUrls baseurl <$>
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 35082eec..8d35991e 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -119,7 +119,7 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
- let calcsz = \mnts -> maybe defSz fudge . getMountSz szm mnts
+ let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
ensureProperty $
@@ -131,8 +131,7 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
-partitionsPopulated chrootdir mnts devs = property desc $
- mconcat $ map (uncurry go) (zip mnts devs)
+partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs
where
desc = "partitions populated from " ++ chrootdir
@@ -200,8 +199,7 @@ getMountSz _ _ Nothing = Nothing
getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
- childsz = mconcat $ catMaybes $
- map (getMountSz szm l) (filter (isChild mntpt) l)
+ childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
isChild :: FilePath -> MountPoint -> Bool
isChild mntpt (Just d)
@@ -274,7 +272,7 @@ extended :: PartSpec -> PartSpec
extended s = adjustp s $ \p -> p { partType = Extended }
adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec
-adjustp (mp, p) f = (mp, \sz -> f (p sz))
+adjustp (mp, p) f = (mp, f . p)
-- | The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
@@ -282,7 +280,7 @@ fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTab
fitChrootSize tt l basesizes = (mounts, parttable)
where
(mounts, sizers) = unzip l
- parttable = PartTable tt (map (uncurry id) (zip sizers basesizes))
+ parttable = PartTable tt (zipWith id sizers basesizes)
-- | A pair of properties. The first property is satisfied within the
-- chroot, and is typically used to download the boot loader.
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 6051ba63..d854ec52 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -97,7 +97,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
, confFile = mknamedconffile zonefile
, confMasters = []
, confAllowTransfer = nub $
- concatMap (\h -> hostAddresses h hosts) $
+ concatMap (`hostAddresses` hosts) $
secondaries ++ nssecondaries
, confLines = []
}
@@ -199,7 +199,7 @@ secondaryFor masters hosts domain = setup <!> cleanup
{ confDomain = domain
, confDnsServerType = Secondary
, confFile = "db." ++ domain
- , confMasters = concatMap (\m -> hostAddresses m hosts) masters
+ , confMasters = concatMap (`hostAddresses` hosts) masters
, confAllowTransfer = []
, confLines = []
}
@@ -425,7 +425,7 @@ type WarningMessage = String
-- Does not include SSHFP records.
genZone :: [Host] -> M.Map HostName Host -> Domain -> SOA -> (Zone, [WarningMessage])
genZone inzdomain hostmap zdomain soa =
- let (warnings, zhosts) = partitionEithers $ concat $ map concat
+ let (warnings, zhosts) = partitionEithers $ concatMap concat
[ map hostips inzdomain
, map hostrecords inzdomain
, map addcnames (M.elems hostmap)
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index e24d58d4..9cfc24b6 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -75,7 +75,7 @@ configured = prop `requires` installed
where
prop = withPrivData src anyContext $ \getcfg ->
property "docker configured" $ getcfg $ \cfg -> ensureProperty $
- "/root/.dockercfg" `File.hasContent` (lines cfg)
+ "/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -213,7 +213,7 @@ garbageCollected = propertyList "docker garbage collected"
where
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
- gcimages = property "docker images garbage collected" $ do
+ gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
-- | Tweaks a container to work well with docker.
@@ -471,8 +471,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
restartcontainer = do
oldimage <- liftIO $
- fromMaybe (toImageID image) . fmap toImageID <$>
- commitContainer cid
+ maybe (toImageID image) toImageID <$> commitContainer cid
void $ liftIO $ removeContainer cid
go oldimage
@@ -631,8 +630,8 @@ data ContainerFilter = RunningContainers | AllContainers
-- | Only lists propellor managed containers.
listContainers :: ContainerFilter -> IO [ContainerId]
listContainers status =
- catMaybes . map toContainerId . concat . map (split ",")
- . catMaybes . map (lastMaybe . words) . lines
+ mapMaybe toContainerId . concatMap (split ",")
+ . mapMaybe (lastMaybe . words) . lines
<$> readProcess dockercmd ps
where
ps
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index adced166..4563fe79 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -40,7 +40,7 @@ hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
property desc $ getcontent $ \privcontent ->
ensureProperty $ fileProperty' writer desc
- (\_oldcontent -> lines privcontent) f
+ (\_oldcontent -> privDataLines privcontent) f
where
desc = "privcontent " ++ f
@@ -103,5 +103,5 @@ ownerGroup f (User owner) (Group group) = property (f ++ " owner " ++ og) $ do
-- | Ensures that a file/dir has the specfied mode.
mode :: FilePath -> FileMode -> Property NoInfo
mode f v = property (f ++ " mode " ++ show v) $ do
- liftIO $ modifyFileMode f (\_old -> v)
+ liftIO $ modifyFileMode f (const v)
noChange
diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs
index 0f68f8fe..e57749ae 100644
--- a/src/Propellor/Property/Gpg.hs
+++ b/src/Propellor/Property/Gpg.hs
@@ -33,7 +33,7 @@ keyImported (GpgKeyId keyid) user@(User u) = flagFile' prop genflag
withHandle StdinHandle createProcessSuccess
(proc "su" ["-c", "gpg --import", u]) $ \h -> do
fileEncoding h
- hPutStr h key
+ hPutStr h (unlines (privDataLines key))
hClose h
src = PrivDataSource GpgKey "Either a gpg public key, exported with gpg --export -a, or a gpg private key, exported with gpg --export-secret-key -a"
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 6a6d5bfd..bd8b1ff3 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -39,10 +39,11 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
-- password used to upload the built image.
rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
property "rsync password" $ getpw $ \pw -> do
- oldpw <- liftIO $ catchDefaultIO "" $
+ have <- liftIO $ catchDefaultIO "" $
readFileStrict pwfile
- if pw /= oldpw
- then makeChange $ writeFile pwfile pw
+ let want = privDataVal pw
+ if want /= have
+ then makeChange $ writeFile pwfile want
else noChange
tree :: Architecture -> Property HasInfo
diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs
index 8c9926bc..68313f20 100644
--- a/src/Propellor/Property/SiteSpecific/IABak.hs
+++ b/src/Propellor/Property/SiteSpecific/IABak.hs
@@ -103,4 +103,4 @@ graphiteServer = propertyList "iabak graphite server" $ props
graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $
\gettoken -> property "graphite-web CSRF token" $
gettoken $ \token -> ensureProperty $ File.containsLine
- "/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ token ++"'")
+ "/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'")
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 5f0082cb..fbd57057 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -147,22 +147,29 @@ hostKeys ctx l = propertyList desc $ catMaybes $
hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
hostKey context keytype pub = combineProperties desc
[ pubKey keytype pub
- , toProp $ property desc $ install writeFile True pub
+ , toProp $ property desc $ install writeFile True (lines pub)
, withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
- property desc $ getkey $ install writeFileProtected False
+ property desc $ getkey $
+ install writeFileProtected False . privDataLines
]
`onChange` restarted
where
desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
- install writer ispub key = do
+ install writer ispub keylines = do
let f = keyFile keytype ispub
- s <- liftIO $ catchDefaultIO "" $ readFileStrict f
- if s == key
+ have <- liftIO $ catchDefaultIO "" $ readFileStrict f
+ let want = keyFileContent keylines
+ if have == want
then noChange
- else makeChange $ writer f key
+ else makeChange $ writer f want
keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
+-- Make sure that there is a newline at the end;
+-- ssh requires this for some types of private keys.
+keyFileContent :: [String] -> String
+keyFileContent keylines = unlines (keylines ++ [""])
+
keyFile :: SshKeyType -> Bool -> FilePath
keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
where
@@ -221,7 +228,7 @@ keyImported' dest keytype user@(User u) context = combineProperties desc
, ensureProperties
[ property desc $ makeChange $ do
createDirectoryIfMissing True (takeDirectory f)
- writer f key
+ writer f (keyFileContent (privDataLines key))
, File.ownerGroup f user (userGroup user)
, File.ownerGroup (takeDirectory f) user (userGroup user)
]
@@ -232,6 +239,8 @@ keyImported' dest keytype user@(User u) context = combineProperties desc
return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext
Just f -> return $ f ++ ext
+
+
fromKeyType :: SshKeyType -> String
fromKeyType SshRsa = "rsa"
fromKeyType SshDsa = "dsa"
@@ -267,7 +276,7 @@ authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) contex
f <- liftIO $ dotFile "authorized_keys" user
liftIO $ do
createDirectoryIfMissing True (takeDirectory f)
- writeFileProtected f v
+ writeFileProtected f (keyFileContent (privDataLines v))
ensureProperties
[ File.ownerGroup f user (userGroup user)
, File.ownerGroup (takeDirectory f) user (userGroup user)
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 535da951..e2ee3dad 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -134,12 +134,12 @@ hiddenServiceData hn context = combineProperties desc
desc = unwords ["hidden service data available in", varLib </> hn]
installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent ->
property desc $ getcontent $ install $ varLib </> hn </> f
- install f content = ifM (liftIO $ doesFileExist f)
+ install f privcontent = ifM (liftIO $ doesFileExist f)
( noChange
, ensureProperties
[ property desc $ makeChange $ do
createDirectoryIfMissing True (takeDirectory f)
- writeFileProtected f content
+ writeFileProtected f (unlines (privDataLines privcontent))
, File.mode (takeDirectory f) $ combineModes
[ownerReadMode, ownerWriteMode, ownerExecuteMode]
, File.ownerGroup (takeDirectory f) user (userGroup user)
diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs
new file mode 100644
index 00000000..950f669e
--- /dev/null
+++ b/src/Propellor/Property/Unbound.hs
@@ -0,0 +1,87 @@
+-- | Properties for the Unbound caching DNS server
+
+module Propellor.Property.Unbound
+ ( installed
+ , restarted
+ , reloaded
+ , genAddressNoTtl
+ , genAddress
+ , genMX
+ , genPTR
+ , revIP
+ , canonical
+ , genZoneStatic
+ , genZoneTransparent
+ ) where
+
+import Propellor
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Service as Service
+
+import Data.List
+import Data.String.Utils (split, replace)
+
+
+installed :: Property NoInfo
+installed = Apt.installed ["unbound"]
+
+restarted :: Property NoInfo
+restarted = Service.restarted "unbound"
+
+reloaded :: Property NoInfo
+reloaded = Service.reloaded "unbound"
+
+dValue :: BindDomain -> String
+dValue (RelDomain d) = d
+dValue (AbsDomain d) = d ++ "."
+dValue (RootDomain) = "@"
+
+genAddressNoTtl :: BindDomain -> IPAddr -> String
+genAddressNoTtl dom = genAddress dom Nothing
+
+genAddress :: BindDomain -> Maybe Int -> IPAddr -> String
+genAddress dom ttl addr = case addr of
+ IPv4 _ -> genAddress' "A" dom ttl addr
+ IPv6 _ -> genAddress' "AAAA" dom ttl addr
+
+genAddress' :: String -> BindDomain -> Maybe Int -> IPAddr -> String
+genAddress' recordtype dom ttl addr = localData $ dValue dom ++ " " ++ maybe "" (\ttl' -> show ttl' ++ " ") ttl ++ "IN " ++ recordtype ++ " " ++ fromIPAddr addr
+
+genMX :: BindDomain -> BindDomain -> Int -> String
+genMX dom dest priority = localData $ dValue dom ++ " " ++ "MX" ++ " " ++ show priority ++ " " ++ dValue dest
+
+genPTR :: BindDomain -> IPAddr -> String
+genPTR dom ip = localData $ revIP ip ++ ". " ++ "PTR" ++ " " ++ dValue dom
+
+revIP :: IPAddr -> String
+revIP (IPv4 addr) = intercalate "." (reverse $ split "." addr) ++ ".in-addr.arpa"
+revIP addr@(IPv6 _) = reverse (intersperse '.' $ replace ":" "" $ fromIPAddr $ canonical addr) ++ ".ip6.arpa"
+
+canonical :: IPAddr -> IPAddr
+canonical (IPv4 addr) = IPv4 addr
+canonical (IPv6 addr) = IPv6 $ intercalate ":" $ map canonicalGroup $ split ":" $ replaceImplicitGroups addr
+ where
+ canonicalGroup g = case length g of
+ 0 -> "0000"
+ 1 -> "000" ++ g
+ 2 -> "00" ++ g
+ 3 -> "0" ++ g
+ _ -> g
+ emptyGroups n = iterate (++ ":") "" !! n
+ numberOfImplicitGroups a = 8 - length (split ":" $ replace "::" "" a)
+ replaceImplicitGroups a = concat $ aux $ split "::" a
+ where
+ aux [] = []
+ aux (x : xs) = x : emptyGroups (numberOfImplicitGroups a) : xs
+
+localData :: String -> String
+localData conf = " local-data: \"" ++ conf ++ "\""
+
+genZoneStatic :: BindDomain -> String
+genZoneStatic dom = localZone (dValue dom) "static"
+
+genZoneTransparent :: BindDomain -> String
+genZoneTransparent dom = localZone (dValue dom) "transparent"
+
+localZone :: String -> String -> String
+localZone zone confzone = " local-zone: \"" ++ zone ++ "\" " ++ confzone
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index add3ae52..c029999f 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -58,8 +58,8 @@ hasPassword' (User u) context = go `requires` shadowConfig True
setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result
setPassword getpassword = getpassword $ go
where
- go (Password user, password) = set user password []
- go (CryptPassword user, hash) = set user hash ["--encrypted"]
+ go (Password user, password) = set user (privDataVal password) []
+ go (CryptPassword user, hash) = set user (privDataVal hash) ["--encrypted"]
go (f, _) = error $ "Unexpected type of privdata: " ++ show f
set user v ps = makeChange $ withHandle StdinHandle createProcessSuccess
diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs
index a3c8e701..e2941420 100644
--- a/src/Propellor/Shim.hs
+++ b/src/Propellor/Shim.hs
@@ -77,7 +77,7 @@ installFile :: FilePath -> FilePath -> IO ()
installFile top f = do
createDirectoryIfMissing True destdir
nukeFile dest
- createLink f dest `catchIO` (const copy)
+ createLink f dest `catchIO` const copy
where
copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest]
destdir = inTop top $ takeDirectory f
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index cce754ca..c5b31cef 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -59,7 +59,7 @@ spin target relay hst = do
-- And now we can run it.
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
- error $ "remote propellor failed"
+ error "remote propellor failed"
where
hn = fromMaybe target relay
@@ -184,7 +184,7 @@ updateServer target relay hst connect haveprecompiled =
let loop = go (toh, fromh)
let restart = updateServer hn relay hst connect haveprecompiled
let done = return ()
- v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
+ v <- maybe Nothing readish <$> getMarked fromh statusMarker
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
@@ -263,7 +263,7 @@ sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
-- This should be reasonably portable, as long as the remote host has the
-- same architecture as the build host.
sendPrecompiled :: HostName -> IO ()
-sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do
+sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor as a last resort" $
bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
withTmpDir "propellor" go
where
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 1fc26892..ce93e144 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -219,7 +219,7 @@ class Combines x y where
-- that ensures the first, and if the first succeeds, ensures the second.
-- The property uses the description of the first property.
before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
-before x y = (y `requires` x) `describe` (getDesc x)
+before x y = (y `requires` x) `describe` getDesc x
-- | Combines together two properties, yielding a property that
-- has the description and info of the first, and that has the second
diff --git a/src/Propellor/Types/Container.hs b/src/Propellor/Types/Container.hs
index d21bada7..ecff5118 100644
--- a/src/Propellor/Types/Container.hs
+++ b/src/Propellor/Types/Container.hs
@@ -17,12 +17,12 @@ data Bound v = Bound
-- For example, @Port 8080 -<- Port 80@ means that port 8080 on the host
-- is bound to port 80 from the container.
(-<-) :: (hostv ~ v, containerv ~ v) => hostv -> containerv -> Bound v
-(-<-) hostv containerv = Bound hostv containerv
+(-<-) = Bound
-- | Flipped version of -<- with the container value first and host value
-- second.
(->-) :: (containerv ~ v, hostv ~ v) => hostv -> containerv -> Bound v
-(->-) containerv hostv = Bound hostv containerv
+(->-) = flip (-<-)
-- | Create a Bound value, that is the same on both the host and container.
same :: v -> Bound v
diff --git a/src/Propellor/Types/PrivData.hs b/src/Propellor/Types/PrivData.hs
index d713c7cf..c72838cb 100644
--- a/src/Propellor/Types/PrivData.hs
+++ b/src/Propellor/Types/PrivData.hs
@@ -1,6 +1,9 @@
module Propellor.Types.PrivData where
import Propellor.Types.OS
+import Utility.PartialPrelude
+
+import Data.Maybe
-- | Note that removing or changing constructors or changing types will
-- break the serialized privdata files, so don't do that!
@@ -89,7 +92,23 @@ anyContext = Context "any"
hostContext :: HostContext
hostContext = HostContext Context
-type PrivData = String
+-- | Contains the actual private data.
+--
+-- Note that this may contain exta newlines at the end, or they may have
+-- been stripped off, depending on how the user entered the privdata,
+-- and which version of propellor stored it. Use the accessor functions
+-- below to avoid newline problems.
+newtype PrivData = PrivData String
+
+-- | When PrivData is the content of a file, this is the lines thereof.
+privDataLines :: PrivData -> [String]
+privDataLines (PrivData s) = lines s
+
+-- | When the PrivData is a single value, like a password, this extracts
+-- it. Note that if multiple lines are present in the PrivData, only
+-- the first is returned; there is never a newline in the String.
+privDataVal :: PrivData -> String
+privDataVal (PrivData s) = fromMaybe "" (headMaybe (lines s))
data SshKeyType = SshRsa | SshDsa | SshEcdsa | SshEd25519
deriving (Read, Show, Ord, Eq, Enum, Bounded)
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index 9d4236c4..13000e03 100644
--- a/src/Utility/Exception.hs
+++ b/src/Utility/Exception.hs
@@ -1,6 +1,6 @@
{- Simple IO exception handling (and some more)
-
- - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2015 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@@ -20,6 +20,7 @@ module Utility.Exception (
catchNonAsync,
tryNonAsync,
tryWhenExists,
+ catchHardwareFault,
) where
import Control.Monad.Catch as X hiding (Handler)
@@ -27,7 +28,9 @@ import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
-import System.IO.Error (isDoesNotExistError)
+import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
+import GHC.IO.Exception (IOErrorType(..))
+
import Utility.Data
{- Catches IO errors and returns a Bool -}
@@ -36,10 +39,7 @@ catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
-catchMaybeIO a = do
- catchDefaultIO Nothing $ do
- v <- a
- return (Just v)
+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)
{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
@@ -87,3 +87,12 @@ tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = do
v <- tryJust (guard . isDoesNotExistError) a
return (eitherToMaybe v)
+
+{- Catches only exceptions caused by hardware faults.
+ - Ie, disk IO error. -}
+catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a
+catchHardwareFault a onhardwareerr = catchIO a onlyhw
+ where
+ onlyhw e
+ | ioeGetErrorType e == HardwareFault = onhardwareerr e
+ | otherwise = throwM e
diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs
index 45d5a063..ebb42576 100644
--- a/src/Utility/Misc.hs
+++ b/src/Utility/Misc.hs
@@ -136,7 +136,7 @@ hGetSomeString h sz = do
- if this reap gets there first. -}
reapZombies :: IO ()
#ifndef mingw32_HOST_OS
-reapZombies = do
+reapZombies =
-- throws an exception when there are no child processes
catchDefaultIO Nothing (getAnyProcessStatus False True)
>>= maybe (return ()) (const reapZombies)
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 469f7659..c4882a01 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -31,6 +31,7 @@ module Utility.Process (
withQuietOutput,
feedWithQuietOutput,
createProcess,
+ waitForProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
@@ -42,7 +43,7 @@ module Utility.Process (
import qualified System.Process
import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
-import System.Process hiding (createProcess, readProcess)
+import System.Process hiding (createProcess, readProcess, waitForProcess)
import System.Exit
import System.IO
import System.Log.Logger
@@ -171,7 +172,7 @@ createBackgroundProcess p a = a =<< createProcess p
-- returns a transcript combining its stdout and stderr, and
-- whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+processTranscript cmd opts = processTranscript' cmd opts Nothing
processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
processTranscript' cmd opts environ input = do
@@ -345,22 +346,6 @@ oeHandles _ = error "expected oeHandles"
processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid
--- | Debugging trace for a CreateProcess.
-debugProcess :: CreateProcess -> IO ()
-debugProcess p = do
- debugM "Utility.Process" $ unwords
- [ action ++ ":"
- , showCmd p
- ]
- where
- action
- | piped (std_in p) && piped (std_out p) = "chat"
- | piped (std_in p) = "feed"
- | piped (std_out p) = "read"
- | otherwise = "call"
- piped Inherit = False
- piped _ = True
-
-- | Shows the command that a CreateProcess will run.
showCmd :: CreateProcess -> String
showCmd = go . cmdspec
@@ -385,9 +370,30 @@ startInteractiveProcess cmd args environ = do
(Just from, Just to, _, pid) <- createProcess p
return (pid, to, from)
--- | Wrapper around 'System.Process.createProcess' from System.Process,
--- that does debug logging.
+-- | Wrapper around 'System.Process.createProcess' that does debug logging.
createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess p = do
debugProcess p
System.Process.createProcess p
+
+-- | Debugging trace for a CreateProcess.
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+-- | Wrapper around 'System.Process.waitForProcess' that does debug logging.
+waitForProcess :: ProcessHandle -> IO ExitCode
+waitForProcess h = do
+ r <- System.Process.waitForProcess h
+ debugM "Utility.Process" ("process done " ++ show r)
+ return r
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index b3813323..5e813d4a 100644
--- a/src/Utility/Scheduled.hs
+++ b/src/Utility/Scheduled.hs
@@ -286,7 +286,7 @@ fromScheduledTime AnyTime = "any time"
fromScheduledTime (SpecificTime h m) =
show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
where
- pad n s = take (n - length s) (repeat '0') ++ s
+ pad n s = replicate (n - length s) '0' ++ s
(h', ampm)
| h == 0 = (12, "AM")
| h < 12 = (h, "AM")
diff --git a/src/Utility/Table.hs b/src/Utility/Table.hs
index 20adf40d..6d4c045b 100644
--- a/src/Utility/Table.hs
+++ b/src/Utility/Table.hs
@@ -26,4 +26,4 @@ formatTable table = map (\r -> unwords (map pad (zip r colsizes))) table
sumcols (map (map length) table)
sumcols [] = repeat 0
sumcols [r] = r
- sumcols (r1:r2:rs) = sumcols $ map (uncurry max) (zip r1 r2) : rs
+ sumcols (r1:r2:rs) = sumcols $ zipWith max r1 r2 : rs