summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-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
14 files changed, 148 insertions, 48 deletions
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
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-14 06:19:52 +0000