summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--config-joey.hs44
-rw-r--r--debian/changelog7
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Gpg.hs10
-rw-r--r--src/Propellor/PrivData.hs7
-rw-r--r--src/Propellor/Property/Apache.hs22
-rw-r--r--src/Propellor/Property/Docker.hs26
-rw-r--r--src/Propellor/Property/Firewall.hs13
-rw-r--r--src/Propellor/Property/Munin.hs3
-rw-r--r--src/Propellor/Property/Network.hs11
-rw-r--r--src/Propellor/Property/OpenId.hs8
-rw-r--r--src/Propellor/Property/Ssh.hs28
-rw-r--r--src/Propellor/Property/Systemd.hs12
-rw-r--r--src/Propellor/Spin.hs26
-rw-r--r--src/Propellor/Types/OS.hs4
-rw-r--r--src/Utility/Process.hs12
-rw-r--r--src/Utility/Process/NonConcurrent.hs35
17 files changed, 162 insertions, 107 deletions
diff --git a/config-joey.hs b/config-joey.hs
index 12846d36..bab8f466 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -38,7 +38,7 @@ import qualified Propellor.Property.SiteSpecific.Branchable as Branchable
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
import Propellor.Property.DiskImage
-main :: IO () -- _ ______`| ,-.__
+main :: IO () -- _ ______`| ,-.__
main = defaultMain hosts -- / \___-=O`/|O`/__| (____.'
{- Propellor -- \ / | / ) _.-"-._
Deployed -} -- `/-==__ _/__|/__=-| ( \_
@@ -133,7 +133,7 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64"
& File.notPresent "/var/www/index.html"
& "/var/www/html/index.html" `File.hasContent` ["hello, world"]
& alias "helloworld.kitenet.net"
-
+
& Systemd.nspawned oldusenetShellBox
& JoeySites.scrollBox
@@ -150,7 +150,7 @@ mayfly = standardSystem "mayfly.kitenet.net" (Stable "jessie") "amd64"
& Network.ipv6to4
& Systemd.persistentJournal
& Journald.systemMaxUse "500MiB"
-
+
& Tor.isRelay
& Tor.named "kite3"
& Tor.bandwidthRate (Tor.PerMonth "400 GB")
@@ -172,11 +172,11 @@ oyster = standardSystem "oyster.kitenet.net" Unstable "amd64"
& Tor.isRelay
& Tor.named "kite2"
& Tor.bandwidthRate (Tor.PerMonth "400 GB")
-
+
-- Nothing is using http port 80, so listen on
-- that port for ssh, for traveling on bad networks that
-- block 22.
- & Ssh.listenPort 80
+ & Ssh.listenPort (Port 80)
orca :: Host
orca = standardSystem "orca.kitenet.net" Unstable "amd64"
@@ -203,7 +203,7 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64"
honeybee :: Host
honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
[ "Arm git-annex build box." ]
-
+
-- I have to travel to get console access, so no automatic
-- upgrades, and try to be robust.
& "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes"
@@ -213,7 +213,7 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf"
& Apt.installed ["linux-image-armmp"]
& Network.dhcp "eth0" `requires` Network.cleanInterfacesFile
& Postfix.satellite
-
+
-- ipv6 used for remote access thru firewalls
& Apt.serviceInstalledRunning "aiccu"
& ipv6 "2001:4830:1600:187::2"
@@ -291,12 +291,12 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
& alias "pop.kitenet.net"
& alias "mail.kitenet.net"
& JoeySites.kiteMailServer
-
+
& JoeySites.kitenetHttps
& JoeySites.legacyWebSites
& File.ownerGroup "/srv/web" (User "joey") (Group "joey")
& Apt.installed ["analog"]
-
+
& alias "git.kitenet.net"
& alias "git.joeyh.name"
& JoeySites.gitServer hosts
@@ -312,7 +312,7 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
, "User = bitlbee"
, "AuthMode = Registered"
, "[defaults]"
- ]
+ ]
`onChange` Service.restarted "bitlbee"
& "/etc/default/bitlbee" `File.containsLine` "BITLBEE_PORT=\"6767\""
`onChange` Service.restarted "bitlbee"
@@ -325,10 +325,10 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64"
-- Some users have zsh as their login shell.
, "zsh"
]
-
+
& alias "nntp.olduse.net"
& JoeySites.oldUseNetServer hosts
-
+
& alias "ns4.kitenet.net"
& myDnsPrimary True "kitenet.net" []
& myDnsPrimary True "joeyh.name" []
@@ -370,7 +370,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& Systemd.persistentJournal
& Ssh.userKeys (User "joey") hostContext
[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC4wJuQEGno+nJvtE75IKL6JQ08sJHZ9Bzs9Dvu0zuxSEZE30MWK98/twNwCH9PVf2N9m4apfN7f9GHgHTUongfo8xnLAk4PuBSTV74YgKyOCvNYqANuKKa+76PsS/vFf/or3ct++uTEWsRyYD29cQndufwKA4rthAqHG+fifbLDC53AjcldI0zI1RckpPzT+AMazlnSBFMlpKvGD2uzSXALVRXa3vSqWkWd0z7qmIkpmpq0AAgbDLwrGBcUGV/h0rOa2s8zSeirA0tLmHNROl4cZsX0T/6VBGfBRkrHSxL67xJziATw4WPq6spYlxg84pC/5qJVr9SC5HosppbDqgj joey@elephant")
- ]
+ ]
& Apt.serviceInstalledRunning "swapspace"
& alias "eubackup.kitenet.net"
@@ -381,27 +381,27 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
& alias "podcatcher.kitenet.net"
& JoeySites.podcatcher
-
+
& alias "znc.kitenet.net"
& JoeySites.ircBouncer
& alias "kgb.kitenet.net"
& JoeySites.kgbServer
-
+
& alias "mumble.kitenet.net"
& JoeySites.mumbleServer hosts
-
+
& alias "ns3.kitenet.net"
& myDnsSecondary
-
+
& Systemd.nspawned oldusenetShellBox
& Systemd.nspawned ancientKitenet
& Systemd.nspawned openidProvider
`requires` Apt.serviceInstalledRunning "ntp"
-
+
& JoeySites.scrollBox
& alias "scroll.joeyh.name"
& alias "eu.scroll.joeyh.name"
-
+
-- For https port 443, shellinabox with ssh login to
-- kitenet.net
& alias "shell.kitenet.net"
@@ -409,7 +409,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64"
-- Nothing is using http port 80, so listen on
-- that port for ssh, for traveling on bad networks that
-- block 22.
- & Ssh.listenPort 80
+ & Ssh.listenPort (Port 80)
beaver :: Host
beaver = host "beaver.kitenet.net"
@@ -429,7 +429,7 @@ pell = host "pell.branchable.com"
& alias "branchable.com"
& ipv4 "66.228.46.55"
& ipv6 "2600:3c03::f03c:91ff:fedf:c0e5"
-
+
-- All the websites I host at branchable that don't use
-- branchable.com dns.
& alias "olduse.net"
@@ -596,7 +596,7 @@ monsters :: [Host] -- Systems I don't manage with propellor,
monsters = -- but do want to track their public keys etc.
[ host "usw-s002.rsync.net"
& Ssh.hostPubKey SshEd25519 "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB7yTEBGfQYdwG/oeL+U9XPMIh/dW7XNs9T+M79YIOrd"
- , host "github.com"
+ , host "github.com"
& Ssh.hostPubKey SshRsa "ssh-rsa AAAAB3NzaC1yc2EAAAABIwAAAQEAq2A7hRGmdnm9tUDbO9IDSwBK6TbQa+PXYPCPy6rbTrTtw7PHkccKrpp0yVhp5HdEIcKr6pLlVDBfOLX9QUsyCOV0wzfjIJNlGEYsdlLJizHhbn2mUjvSAHQqZETYP81eFzLQNnPHt4EVVUh7VfDESU84KezmD5QlWpXLmvU31/yMf+Se8xhHTvKSCZIFImWwoG6mbUoWf9nzpIoaSjB+weqqUUmpaaasXVal72J+UX2B+2RPW3RcT0eOzQgqlJL3RKrTJvdsjE3JEAvGq3lGHSZXy28G3skua2SmVi/w4yCE6gbODqnTWlg7+wC604ydGXA8VJiS5ap43JXiUFFAaQ=="
, host "gitlab.com"
& Ssh.hostPubKey SshEcdsa "ecdsa-sha2-nistp256 AAAAE2VjZHNhLXNoYTItbmlzdHAyNTYAAAAIbmlzdHAyNTYAAABBBFSMqzJeV9rUzU4kWitGjeR4PWSa29SPqJ1fVkhtj3Hw9xjLVXVYrU9QlYWrOLXBpQ6KWjbjTDTdDkoohFzgbEY="
diff --git a/debian/changelog b/debian/changelog
index 1b4c3998..74911c24 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -9,11 +9,16 @@ propellor (2.17.0) UNRELEASED; urgency=medium
Thanks, Félix Sipma.
* Firewall: Separated Table and Target (API change)
Thanks, Félix Sipma.
- * Firewall: add TCPFlag, Frequency, TCPSyn, ICMPTypeMatch
+ * Firewall: add TCPFlag, Frequency, TCPSyn, ICMPTypeMatch, NatDestination
Thanks, Félix Sipma.
* Locale.available: Run locale-gen, instead of dpkg-reconfigure locales,
which modified the locale.gen file and sometimes caused the property to
need to make changes every time.
+ * Force ssh, scp, and git commands to be run in the foreground.
+ * Network: Filter out characters not allowed in interfaces.d files.
+ Thanks, Félix Sipma.
+ * Ssh: hange type of listenPort from Int to Port (API change)
+ Thanks, Félix Sipma.
-- Joey Hess <id@joeyh.name> Mon, 29 Feb 2016 17:58:08 -0400
diff --git a/propellor.cabal b/propellor.cabal
index a281e277..c55bf912 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -182,6 +182,7 @@ Library
Utility.PosixFiles
Utility.Process
Utility.Process.Shim
+ Utility.Process.NonConcurrent
Utility.SafeCommand
Utility.Scheduled
Utility.Table
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index d3550e88..a13734b4 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -6,8 +6,6 @@ import System.Directory
import Data.Maybe
import Data.List.Utils
import Control.Monad
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
import Control.Applicative
import Prelude
@@ -16,6 +14,7 @@ import Propellor.Message
import Propellor.Git.Config
import Utility.SafeCommand
import Utility.Process
+import Utility.Process.NonConcurrent
import Utility.Monad
import Utility.Misc
import Utility.Tmp
@@ -144,12 +143,7 @@ gitCommit msg ps = do
let ps' = Param "commit" : ps ++
maybe [] (\m -> [Param "-m", Param m]) msg
ps'' <- gpgSignParams ps'
- if isNothing msg
- then do
- (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $
- proc "git" (toCommand ps'')
- checkSuccessProcess p
- else boolSystem "git" ps''
+ boolSystemNonConcurrent "git" ps''
gpgDecrypt :: FilePath -> IO String
gpgDecrypt f = do
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 2ed75e33..ac7b00d3 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -34,8 +34,6 @@ import "mtl" Control.Monad.Reader
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
-import System.Console.Concurrent
-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))
import Control.Applicative
import Data.Monoid
import Prelude
@@ -52,12 +50,12 @@ import Utility.PartialPrelude
import Utility.Exception
import Utility.Tmp
import Utility.SafeCommand
+import Utility.Process.NonConcurrent
import Utility.Misc
import Utility.FileMode
import Utility.Env
import Utility.Table
import Utility.FileSystemEncoding
-import Utility.Process
-- | Allows a Property to access the value of a specific PrivDataField,
-- for use in a specific Context or HostContext.
@@ -196,8 +194,7 @@ editPrivData field context = do
hClose th
maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v
editor <- getEnvDefault "EDITOR" "vi"
- (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f]
- unlessM (checkSuccessProcess p) $
+ unlessM (boolSystemNonConcurrent editor [File f]) $
error "Editor failed; aborting."
PrivData <$> readFile f
setPrivDataTo field context v'
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index dee7a5fc..e107cb9f 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -27,7 +27,7 @@ siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain)
[ siteAvailable domain cf
`requires` installed
`onChange` reloaded
- , check (not <$> isenabled)
+ , check (not <$> isenabled)
(cmdProperty "a2ensite" ["--quiet", domain])
`requires` installed
`onChange` reloaded
@@ -37,7 +37,7 @@ siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain)
siteDisabled :: Domain -> Property NoInfo
siteDisabled domain = combineProperties
- ("apache site disabled " ++ domain)
+ ("apache site disabled " ++ domain)
(map File.notPresent (siteCfg domain))
`onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange)
`requires` installed
@@ -72,7 +72,7 @@ listenPorts :: [Port] -> Property NoInfo
listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps
`onChange` restarted
where
- portline (Port n) = "Listen " ++ show n
+ portline port = "Listen " ++ fromPort port
-- This is a list of config files because different versions of apache
-- use different filenames. Propellor simply writes them all.
@@ -82,7 +82,7 @@ siteCfg domain =
[ "/etc/apache2/sites-available/" ++ domain
-- Debian 2.4+
, "/etc/apache2/sites-available/" ++ domain ++ ".conf"
- ]
+ ]
-- | Configure apache to use SNI to differentiate between
-- https hosts.
@@ -130,13 +130,13 @@ type WebRoot = FilePath
-- | A basic virtual host, publishing a directory, and logging to
-- the combined apache log file. Not https capable.
virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo
-virtualHost domain (Port p) docroot = virtualHost' domain (Port p) docroot []
+virtualHost domain port docroot = virtualHost' domain port docroot []
-- | Like `virtualHost` but with additional config lines added.
virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo
-virtualHost' domain (Port p) docroot addedcfg = siteEnabled domain $
- [ "<VirtualHost *:"++show p++">"
- , "ServerName "++domain++":"++show p
+virtualHost' domain port docroot addedcfg = siteEnabled domain $
+ [ "<VirtualHost *:" ++ fromPort port ++ ">"
+ , "ServerName " ++ domain ++ ":" ++ fromPort port
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
@@ -201,9 +201,9 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
, "SSLCertificateChainFile " ++ LetsEncrypt.chainFile domain
]
sslconffile s = "/etc/apache2/sites-available/ssl/" ++ domain ++ "/" ++ s ++ ".conf"
- vhost (Port p) ls =
- [ "<VirtualHost *:"++show p++">"
- , "ServerName "++domain++":"++show p
+ vhost p ls =
+ [ "<VirtualHost *:" ++ fromPort p ++">"
+ , "ServerName " ++ domain ++ ":" ++ fromPort p
, "DocumentRoot " ++ docroot
, "ErrorLog /var/log/apache2/error.log"
, "LogLevel warn"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 932ba2c1..ebc0b301 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -75,7 +75,7 @@ configured :: Property HasInfo
configured = prop `requires` installed
where
prop = withPrivData src anyContext $ \getcfg ->
- property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+ property "docker configured" $ getcfg $ \cfg -> ensureProperty $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -115,7 +115,7 @@ container cn image = Container image (Host cn [] info)
info = dockerInfo mempty
-- | Ensures that a docker container is set up and running.
---
+--
-- The container has its own Properties which are handled by running
-- propellor inside the container.
--
@@ -186,7 +186,7 @@ propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
cn = hostName h
mkContainerInfo :: ContainerId -> Container -> ContainerInfo
-mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
+mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
ContainerInfo img runparams
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
@@ -233,7 +233,7 @@ tweaked = cmdProperty "sh"
`assume` NoChange
`describe` "tweaked for docker"
--- | Configures the kernel to respect docker memory limits.
+-- | Configures the kernel to respect docker memory limits.
--
-- This assumes the system boots using grub 2. And that you don't need any
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
@@ -241,7 +241,7 @@ tweaked = cmdProperty "sh"
-- Only takes effect after reboot. (Not automated.)
memoryLimited :: Property NoInfo
memoryLimited = "/etc/default/grub" `File.containsLine` cfg
- `describe` "docker memory limited"
+ `describe` "docker memory limited"
`onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
@@ -315,7 +315,7 @@ class Publishable p where
toPublish :: p -> String
instance Publishable (Bound Port) where
- toPublish p = show (hostSide p) ++ ":" ++ show (containerSide p)
+ toPublish p = fromPort (hostSide p) ++ ":" ++ fromPort (containerSide p)
-- | string format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort
instance Publishable String where
@@ -355,7 +355,7 @@ volumes_from :: ContainerName -> Property HasInfo
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
--- | Work dir inside the container.
+-- | Work dir inside the container.
workdir :: String -> Property HasInfo
workdir = runProp "workdir"
@@ -409,7 +409,7 @@ environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
-- on which it's deployed.
-data ContainerId = ContainerId
+data ContainerId = ContainerId
{ containerHostName :: HostName
, containerName :: ContainerName
}
@@ -503,7 +503,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
v <- a
case v of
Right Nothing -> do
- threadDelaySeconds (Seconds 1)
+ threadDelaySeconds (Seconds 1)
retry (n-1) a
_ -> return v
@@ -569,7 +569,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d
r <- withHandle StdoutHandle createProcessSuccess p $
processChainOutput
when (r /= FailedChange) $
- setProvisionedFlag cid
+ setProvisionedFlag cid
return r
toChain :: ContainerId -> CmdLine
@@ -600,9 +600,9 @@ startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
stoppedContainer :: ContainerId -> Property NoInfo
-stoppedContainer cid = containerDesc cid $ property desc $
+stoppedContainer cid = containerDesc cid $ property desc $
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty
+ ( liftIO cleanup `after` ensureProperty
(property desc $ liftIO $ toResult <$> stopContainer cid)
, return NoChange
)
@@ -638,7 +638,7 @@ data ContainerFilter = RunningContainers | AllContainers
-- | Only lists propellor managed containers.
listContainers :: ContainerFilter -> IO [ContainerId]
-listContainers status =
+listContainers status =
mapMaybe toContainerId . concatMap (split ",")
. mapMaybe (lastMaybe . words) . lines
<$> readProcess dockercmd ps
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index cb0f0b64..fa1f95d4 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -51,9 +51,9 @@ toIpTable r = map Param $
toIpTableArg :: Rules -> [String]
toIpTableArg Everything = []
toIpTableArg (Proto proto) = ["-p", map toLower $ show proto]
-toIpTableArg (DPort (Port port)) = ["--dport", show port]
-toIpTableArg (DPortRange (Port f, Port t)) =
- ["--dport", show f ++ ":" ++ show t]
+toIpTableArg (DPort port) = ["--dport", fromPort port]
+toIpTableArg (DPortRange (portf, portt)) =
+ ["--dport", fromPort portf ++ ":" ++ fromPort portt]
toIpTableArg (InIFace iface) = ["-i", iface]
toIpTableArg (OutIFace iface) = ["-o", iface]
toIpTableArg (Ctstate states) =
@@ -87,6 +87,10 @@ toIpTableArg (Destination ipwm) =
[ "-d"
, intercalate "," (map fromIPWithMask ipwm)
]
+toIpTableArg (NatDestination ip mport) =
+ [ "--to-destination"
+ , fromIPAddr ip ++ maybe "" (\p -> ":" ++ fromPort p) mport
+ ]
toIpTableArg (r :- r') = toIpTableArg r <> toIpTableArg r'
data IPWithMask = IPWithNoMask IPAddr | IPWithIPMask IPAddr IPAddr | IPWithNumMask IPAddr Int
@@ -167,7 +171,7 @@ data Rules
-- ^There is actually some order dependency between proto and port so this should be a specific
-- data type with proto + ports
| DPort Port
- | DPortRange (Port,Port)
+ | DPortRange (Port, Port)
| InIFace Network.Interface
| OutIFace Network.Interface
| Ctstate [ ConnectionState ]
@@ -177,6 +181,7 @@ data Rules
| TCPSyn
| Source [ IPWithMask ]
| Destination [ IPWithMask ]
+ | NatDestination IPAddr (Maybe Port)
| Rules :- Rules -- ^Combine two rules
deriving (Eq, Show)
diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs
index 43112a6c..2464985a 100644
--- a/src/Propellor/Property/Munin.hs
+++ b/src/Propellor/Property/Munin.hs
@@ -47,10 +47,9 @@ hostListFragment' hs os = concatMap muninHost hs
muninHost :: Host -> [String]
muninHost h = [ "[" ++ (hostName h) ++ "]"
, " address " ++ maybe (hostName h) (fromIPAddr . fst) (hOverride h)
- ] ++ (maybe [] (\x -> [" port " ++ (show $ fromPort $ snd x)]) (hOverride h)) ++ [""]
+ ] ++ (maybe [] (\x -> [" port " ++ (fromPort $ snd x)]) (hOverride h)) ++ [""]
hOverride :: Host -> Maybe (IPAddr, Port)
hOverride h = lookup (hostName h) os
- fromPort (Port p) = p
-- | Create the host list fragment for master config.
hostListFragment :: [Host] -> [String]
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 1908bbb3..382f5d9d 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -3,6 +3,8 @@ module Propellor.Property.Network where
import Propellor.Base
import Propellor.Property.File
+import Data.Char
+
type Interface = String
ifUp :: Interface -> Property NoInfo
@@ -45,7 +47,7 @@ dhcp iface = hasContent (interfaceDFile iface)
--
-- If the interface file already exists, this property does nothing,
-- no matter its content.
---
+--
-- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.)
static :: Interface -> Property NoInfo
@@ -97,7 +99,12 @@ interfacesFile = "/etc/network/interfaces"
-- | A file in the interfaces.d directory.
interfaceDFile :: Interface -> FilePath
-interfaceDFile iface = "/etc/network/interfaces.d" </> iface
+interfaceDFile i = "/etc/network/interfaces.d" </> escapeInterfaceDName i
+
+-- | /etc/network/interfaces.d/ files have to match -- ^[a-zA-Z0-9_-]+$
+-- see "man 5 interfaces"
+escapeInterfaceDName :: Interface -> FilePath
+escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-"))
-- | Ensures that files in the the interfaces.d directory are used.
interfacesDEnabled :: Property NoInfo
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index bafca041..0f73bfb6 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -28,21 +28,21 @@ providerFor users hn mp = propertyList desc $ props
where
baseurl = hn ++ case mp of
Nothing -> ""
- Just (Port p) -> ':' : show p
+ Just p -> ':' : fromPort p
url = "http://"++baseurl++"/simpleid"
desc = "openid provider " ++ url
setbaseurl l
- | "SIMPLEID_BASE_URL" `isInfixOf` l =
+ | "SIMPLEID_BASE_URL" `isInfixOf` l =
"define('SIMPLEID_BASE_URL', '"++url++"');"
| otherwise = l
-
+
apacheconfigured = case mp of
Nothing -> toProp $
Apache.virtualHost hn (Port 80) "/var/www/html"
Just p -> propertyList desc $ props
& Apache.listenPorts [p]
& Apache.virtualHost hn p "/var/www/html"
-
+
-- the identities directory controls access, so open up
-- file mode
identfile (User u) = File.hasPrivContentExposed
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index b67c53dd..26cdbeb7 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -75,7 +75,7 @@ setSshdConfig setting val = File.fileProperty desc f sshdConfig
| s == cfgline = True
| (setting ++ " ") `isPrefixOf` s = False
| otherwise = True
- f ls
+ f ls
| cfgline `elem` ls = filter wantedline ls
| otherwise = filter wantedline ls ++ [cfgline]
@@ -94,7 +94,7 @@ passwordAuthentication = setSshdConfigBool "PasswordAuthentication"
-- | Configure ssh to not allow password logins.
--
--- To prevent lock-out, this is done only once root's
+-- To prevent lock-out, this is done only once root's
-- authorized_keys is in place.
noPasswords :: Property NoInfo
noPasswords = check (hasAuthorizedKeys (User "root")) $
@@ -114,10 +114,10 @@ dotFile f user = do
-- ports it is configured to listen on.
--
-- Revert to prevent it listening on a particular port.
-listenPort :: Int -> RevertableProperty NoInfo
+listenPort :: Port -> RevertableProperty NoInfo
listenPort port = enable <!> disable
where
- portline = "Port " ++ show port
+ portline = "Port " ++ fromPort port
enable = sshdConfig `File.containsLine` portline
`describe` ("ssh listening on " ++ portline)
`onChange` restarted
@@ -173,7 +173,7 @@ hostKeys ctx l = propertyList desc $ catMaybes $
-- | Installs a single ssh host key of a particular type.
--
-- The public key is provided to this function;
--- the private key comes from the privdata;
+-- the private key comes from the privdata;
hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
hostKey context keytype pub = combineProperties desc
[ hostPubKey keytype pub
@@ -210,7 +210,7 @@ hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
getHostPubKey = fromHostKeyInfo <$> askInfo
-newtype HostKeyInfo = HostKeyInfo
+newtype HostKeyInfo = HostKeyInfo
{ fromHostKeyInfo :: M.Map SshKeyType PubKeyText }
deriving (Eq, Ord, Typeable, Show)
@@ -219,7 +219,7 @@ instance IsInfo HostKeyInfo where
instance Monoid HostKeyInfo where
mempty = HostKeyInfo M.empty
- mappend (HostKeyInfo old) (HostKeyInfo new) =
+ mappend (HostKeyInfo old) (HostKeyInfo new) =
-- new first because union prefers values from the first
-- parameter when there is a duplicate key
HostKeyInfo (new `M.union` old)
@@ -240,12 +240,12 @@ instance IsInfo UserKeyInfo where
instance Monoid UserKeyInfo where
mempty = UserKeyInfo M.empty
- mappend (UserKeyInfo old) (UserKeyInfo new) =
+ mappend (UserKeyInfo old) (UserKeyInfo new) =
UserKeyInfo (M.unionWith S.union old new)
-- | Sets up a user with the specified public keys, and the corresponding
-- private keys from the privdata.
---
+--
-- The public keys are added to the Info, so other properties like
-- `authorizedKeysFrom` can use them.
userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
@@ -277,7 +277,7 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) =
, Just $ "(" ++ fromKeyType keytype ++ ")"
]
pubkey = property desc $ install File.hasContent ".pub" [pubkeytext]
- privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
+ privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
property desc $ getkey $
install File.hasContentProtected "" . privDataLines
install writer ext key = do
@@ -349,7 +349,7 @@ modKnownHost user f p = ensureProperty $ p
--
-- Any other lines in the authorized_keys file are preserved as-is.
authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
-localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
+localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
property desc (go =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
@@ -372,9 +372,9 @@ localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) =
go [] = return NoChange
go ls = ensureProperty $ combineProperties desc $
map (revert . authorizedKey localuser) ls
-
+
authorizedKeyLines :: User -> Host -> Propellor [File.Line]
-authorizedKeyLines remoteuser remotehost =
+authorizedKeyLines remoteuser remotehost =
map snd <$> fromHost' remotehost (getUserPubKeys remoteuser)
-- | Makes a user have authorized_keys from the PrivData
@@ -404,7 +404,7 @@ authorizedKey user@(User u) l = add <!> remove
`requires` File.dirExists (takeDirectory f)
remove = property (u ++ " lacks authorized_keys") $ do
f <- liftIO $ dotFile "authorized_keys" user
- ifM (liftIO $ doesFileExist f)
+ ifM (liftIO $ doesFileExist f)
( modAuthorizedKey f user $ f `File.lacksLine` l
, return NoChange
)
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 5a08fb1e..0ad2186e 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -127,7 +127,7 @@ journald = "systemd-journald"
-- | Enables persistent storage of the journal.
persistentJournal :: Property NoInfo
-persistentJournal = check (not <$> doesDirectoryExist dir) $
+persistentJournal = check (not <$> doesDirectoryExist dir) $
combineProperties "persistent systemd journal"
[ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
`assume` MadeChange
@@ -145,7 +145,7 @@ type Option = String
-- Does not ensure that the relevant daemon notices the change immediately.
--
-- This assumes that there is only one [Header] per file, which is
--- currently the case for files like journald.conf and system.conf.
+-- currently the case for files like journald.conf and system.conf.
-- And it assumes the file already exists with
-- the right [Header], so new lines can just be appended to the end.
configured :: FilePath -> Option -> String -> Property NoInfo
@@ -232,7 +232,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
- containerprovisioned =
+ containerprovisioned =
Chroot.propellChroot chroot (enterContainerProcess c) False
<!>
doNothing
@@ -261,7 +261,7 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
, "--machine=%i"
] ++ nspawnServiceParams cfg
| otherwise = l
-
+
goodservicefile = (==)
<$> servicefilecontent
<*> catchDefaultIO "" (readFile servicefile)
@@ -368,7 +368,7 @@ class Publishable a where
toPublish :: a -> String
instance Publishable Port where
- toPublish (Port n) = show n
+ toPublish port = fromPort port
instance Publishable (Bound Port) where
toPublish v = toPublish (hostSide v) ++ ":" ++ toPublish (containerSide v)
@@ -380,7 +380,7 @@ instance Publishable (Proto, Bound Port) where
toPublish (UDP, fp) = "udp:" ++ toPublish fp
-- | Publish a port from the container to the host.
---
+--
-- This feature was first added in systemd version 220.
--
-- This property is only needed (and will only work) if the container
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 6666d089..a2afe29f 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -32,6 +32,7 @@ import Propellor.Types.Info
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
+import Utility.Process.NonConcurrent
commitSpin :: IO ()
commitSpin = do
@@ -61,7 +62,7 @@ commitSpin = do
-- us needing to send stuff directly to the remote host.
whenM hasOrigin $
void $ actionMessage "Push to central git repository" $
- boolSystem "git" [Param "push"]
+ boolSystemNonConcurrent "git" [Param "push"]
spin :: Maybe HostName -> HostName -> Host -> IO ()
spin = spin' Nothing
@@ -87,7 +88,7 @@ spin' mprivdata relay target hst = do
=<< getprivdata
-- And now we can run it.
- unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
+ unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
error "remote propellor failed"
where
hn = fromMaybe target relay
@@ -191,9 +192,9 @@ update forhost = do
hClose stdout
-- Not using git pull because git 2.5.0 badly
-- broke its option parser.
- unlessM (boolSystem "git" (pullparams hin hout)) $
+ unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
errorMessage "git fetch from client failed"
- unlessM (boolSystem "git" [Param "merge", Param "FETCH_HEAD"]) $
+ unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where
pullparams hin hout =
@@ -216,8 +217,13 @@ updateServer
-> CreateProcess
-> PrivMap
-> IO ()
-updateServer target relay hst connect haveprecompiled privdata =
- withIOHandles createProcessSuccess connect go
+updateServer target relay hst connect haveprecompiled privdata = do
+ (Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ }
+ go (toh, fromh)
+ forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid
where
hn = fromMaybe target relay
@@ -280,8 +286,8 @@ sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
- , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
+ , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
+ , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
@@ -317,8 +323,8 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
withTmpFile "propellor.tar." $ \tarball _ -> allM id
[ boolSystem "strip" [File me]
, boolSystem "tar" [Param "czf", File tarball, File shimdir]
- , boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
- , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
+ , boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
+ , boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
]
remotetarball = "/usr/local/propellor.tar"
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 5b425f71..a1ba14d4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -15,6 +15,7 @@ module Propellor.Types.OS (
Group(..),
userGroup,
Port(..),
+ fromPort,
) where
import Network.BSD (HostName)
@@ -75,3 +76,6 @@ userGroup (User u) = Group u
newtype Port = Port Int
deriving (Eq, Show)
+
+fromPort :: Port -> String
+fromPort (Port p) = show p
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index c6699961e..ed02f49e 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -18,6 +18,7 @@ module Utility.Process (
readProcessEnv,
writeReadProcessEnv,
forceSuccessProcess,
+ forceSuccessProcess',
checkSuccessProcess,
ignoreFailureProcess,
createProcessSuccess,
@@ -129,11 +130,12 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do
-- | Waits for a ProcessHandle, and throws an IOError if the process
-- did not exit successfully.
forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
-forceSuccessProcess p pid = do
- code <- waitForProcess pid
- case code of
- ExitSuccess -> return ()
- ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n
+forceSuccessProcess p pid = waitForProcess pid >>= forceSuccessProcess' p
+
+forceSuccessProcess' :: CreateProcess -> ExitCode -> IO ()
+forceSuccessProcess' _ ExitSuccess = return ()
+forceSuccessProcess' p (ExitFailure n) = fail $
+ showCmd p ++ " exited " ++ show n
-- | Waits for a ProcessHandle and returns True if it exited successfully.
-- Note that using this with createProcessChecked will throw away
diff --git a/src/Utility/Process/NonConcurrent.hs b/src/Utility/Process/NonConcurrent.hs
new file mode 100644
index 00000000..d25d2a24
--- /dev/null
+++ b/src/Utility/Process/NonConcurrent.hs
@@ -0,0 +1,35 @@
+{- Running processes in the foreground, not via the concurrent-output
+ - layer.
+ -
+ - Avoid using this in propellor properties!
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.NonConcurrent where
+
+import System.Process
+import System.Exit
+import System.IO
+import Utility.SafeCommand
+import Control.Applicative
+import Prelude
+
+boolSystemNonConcurrent :: String -> [CommandParam] -> IO Bool
+boolSystemNonConcurrent cmd params = do
+ (Nothing, Nothing, Nothing, p) <- createProcessNonConcurrent $
+ proc cmd (toCommand params)
+ dispatch <$> waitForProcessNonConcurrent p
+ where
+ dispatch ExitSuccess = True
+ dispatch _ = False
+
+createProcessNonConcurrent :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcessNonConcurrent = createProcess
+
+waitForProcessNonConcurrent :: ProcessHandle -> IO ExitCode
+waitForProcessNonConcurrent = waitForProcess