Merge branch 'joeyconfig'

2 files changed, 141 insertions, 80 deletions

diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 6d9db8bf..a0ae9cb5 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -88,6 +88,8 @@ processCmdLine = go =<< getArgs
 		Just cmdline -> return $ mk cmdline
 		Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"
 
+data CanRebuild = CanRebuild | NoRebuild
+
 -- | Runs propellor on hosts, as controlled by command-line options.
 defaultMain :: [Host] -> IO ()
 defaultMain hostlist = withConcurrentOutput $ do
@@ -95,10 +97,9 @@ defaultMain hostlist = withConcurrentOutput $ do
 	checkDebugMode
 	cmdline <- processCmdLine
 	debug ["command line: ", show cmdline]
-	go True cmdline
+	go CanRebuild cmdline
   where
-	go _ (Serialized cmdline) = go True cmdline
-	go _ (Continue cmdline) = go False cmdline
+	go cr (Serialized cmdline) = go cr cmdline
 	go _ Check = return ()
 	go _ (Set field context) = setPrivData field context
 	go _ (Unset field context) = unsetPrivData field context
@@ -112,26 +113,32 @@ defaultMain hostlist = withConcurrentOutput $ do
 	go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
 	go _ (DockerInit hn) = Docker.init hn
 	go _ (GitPush fin fout) = gitPushHelper fin fout
-	go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h))
+	go cr (Relay h) = forceConsole >> updateFirst cr (Update (Just h)) (update (Just h))
 	go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
 	go _ (Update (Just h)) = update (Just h)
 	go _ Merge = mergeSpin
-	go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
-	go True cmdline = updateFirst cmdline $ go False cmdline
-	go False (Spin hs mrelay) = do
+	go cr cmdline@(Spin hs mrelay) = buildFirst cr cmdline $ do
 		unless (isJust mrelay) commitSpin
 		forM_ hs $ \hn -> withhost hn $ spin mrelay hn
-	go False cmdline@(SimpleRun hn) = do
-		forceConsole
-		buildFirst cmdline $ go False (Run hn)
-	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
-		( onlyprocess $ withhost hn mainProperties
-		, go True (Spin [hn] Nothing)
-		)
+	go cr (Run hn) = fetchFirst $
+		ifM ((==) 0 <$> getRealUserID)
+			( runhost hn
+			, go cr (Spin [hn] Nothing)
+			)
+	go _ (SimpleRun hn) = runhost hn
+	go cr (Continue cmdline@(SimpleRun hn)) =
+		-- --continue SimpleRun is used by --spin,
+		-- and unlike all other uses of --continue, this legacy one
+		-- wants a build first
+		forceConsole >> fetchFirst (buildFirst cr cmdline (runhost hn))
+	-- When continuing after a rebuild, don't want to rebuild again.
+	go _ (Continue cmdline) = go NoRebuild cmdline
 
 	withhost :: HostName -> (Host -> IO ()) -> IO ()
 	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
 	
+	runhost hn = onlyprocess $ withhost hn mainProperties
+
 	onlyprocess = onlyProcess (localdir </> ".lock")
 
 unknownhost :: HostName -> [Host] -> IO a
@@ -142,8 +149,8 @@ unknownhost h hosts = errorMessage $ unlines
 	, "Known hosts: " ++ unwords (map hostName hosts)
 	]
 
-buildFirst :: CmdLine -> IO () -> IO ()
-buildFirst cmdline next = do
+buildFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
+buildFirst CanRebuild cmdline next = do
 	oldtime <- getmtime
 	buildPropellor
 	newtime <- getmtime
@@ -155,6 +162,7 @@ buildFirst cmdline next = do
 			]
   where
 	getmtime = catchMaybeIO $ getModificationTime "propellor"
+buildFirst NoRebuild _ next = next
 
 fetchFirst :: IO () -> IO ()
 fetchFirst next = do
@@ -162,11 +170,14 @@ fetchFirst next = do
 		void fetchOrigin
 	next
 
-updateFirst :: CmdLine -> IO () -> IO ()
-updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
+updateFirst :: CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst canrebuild cmdline next = ifM hasOrigin
+	( updateFirst' canrebuild cmdline next
+	, next
+	)
 
-updateFirst' :: CmdLine -> IO () -> IO ()
-updateFirst' cmdline next = ifM fetchOrigin
+updateFirst' :: CanRebuild -> CmdLine -> IO () -> IO ()
+updateFirst' CanRebuild cmdline next = ifM fetchOrigin
 	( do
 		buildPropellor
 		void $ boolSystem "./propellor"
@@ -175,6 +186,7 @@ updateFirst' cmdline next = ifM fetchOrigin
 			]
 	, next
 	)
+updateFirst' NoRebuild _ next = next
 
 -- Gets the fully qualified domain name, given a string that might be
 -- a short name to look up in the DNS.
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index eefc8342..c4d2ee1b 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -7,14 +7,12 @@ module Propellor.Property.Firewall (
 	installed,
 	Chain(..),
 	Table(..),
-	TargetFilter(..),
-	TargetNat(..),
-	TargetMangle(..),
-	TargetRaw(..),
-	TargetSecurity(..),
+	Target(..),
 	Proto(..),
 	Rules(..),
 	ConnectionState(..),
+	ICMPTypeMatch(..),
+	Frequency(..),
 	IPWithMask(..),
 	fromIPWithMask
 ) where
@@ -30,10 +28,10 @@ import qualified Propellor.Property.Network as Network
 installed :: Property NoInfo
 installed = Apt.installed ["iptables"]
 
-rule :: Chain -> Table -> Rules -> Property NoInfo
-rule c t rs = property ("firewall rule: " <> show r) addIpTable
+rule :: Chain -> Table -> Target -> Rules -> Property NoInfo
+rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
   where
-	r = Rule c t rs
+	r = Rule c tb tg rs
 	addIpTable = liftIO $ do
 		let args = toIpTable r
 		exist <- boolSystem "iptables" (chk args)
@@ -45,8 +43,9 @@ rule c t rs = property ("firewall rule: " <> show r) addIpTable
 
 toIpTable :: Rule -> [CommandParam]
 toIpTable r =  map Param $
-	show (ruleChain r) :
-	toIpTableArg (ruleRules r) ++ toIpTableTable (ruleTable r)
+	fromChain (ruleChain r) :
+	toIpTableArg (ruleRules r) ++
+	["-t", fromTable (ruleTable r), "-j", fromTarget (ruleTarget r)]
 
 toIpTableArg :: Rules -> [String]
 toIpTableArg Everything = []
@@ -61,6 +60,24 @@ toIpTableArg (Ctstate states) =
 	, "conntrack"
 	, "--ctstate", intercalate "," (map show states)
 	]
+toIpTableArg (ICMPType i) =
+	[ "-m"
+	, "icmp"
+	, "--icmp-type", fromICMPTypeMatch i
+	]
+toIpTableArg (RateLimit f) =
+	[ "-m"
+	, "limit"
+	, "--limit", fromFrequency f
+	]
+toIpTableArg (TCPFlags m c) =
+	[ "-m"
+	, "tcp"
+	, "--tcp-flags"
+	, intercalate "," (map show m)
+	, intercalate "," (map show c)
+	]
+toIpTableArg TCPSyn = ["--syn"]
 toIpTableArg (Source ipwm) =
 	[ "-s"
 	, intercalate "," (map fromIPWithMask ipwm)
@@ -80,78 +97,86 @@ fromIPWithMask (IPWithIPMask ip ipm) = fromIPAddr ip ++ "/" ++ fromIPAddr ipm
 fromIPWithMask (IPWithNumMask ip m) = fromIPAddr ip ++ "/" ++ show m
 
 data Rule = Rule
-	{ ruleChain :: Chain
-	, ruleTable :: Table
-	, ruleRules :: Rules
+	{ ruleChain  :: Chain
+	, ruleTable  :: Table
+	, ruleTarget :: Target
+	, ruleRules  :: Rules
 	} deriving (Eq, Show)
 
-data Table = Filter TargetFilter | Nat TargetNat | Mangle TargetMangle | Raw TargetRaw | Security TargetSecurity
+data Table = Filter | Nat | Mangle | Raw | Security
 	deriving (Eq, Show)
 
-toIpTableTable :: Table -> [String]
-toIpTableTable f = ["-t", table, "-j", target]
-  where
-	(table, target) = toIpTableTable' f
-
-toIpTableTable' :: Table -> (String, String)
-toIpTableTable' (Filter target) = ("filter", fromTarget target)
-toIpTableTable' (Nat target) = ("nat", fromTarget target)
-toIpTableTable' (Mangle target) = ("mangle", fromTarget target)
-toIpTableTable' (Raw target) = ("raw", fromTarget target)
-toIpTableTable' (Security target) = ("security", fromTarget target)
+fromTable :: Table -> String
+fromTable Filter = "filter"
+fromTable Nat = "nat"
+fromTable Mangle = "mangle"
+fromTable Raw = "raw"
+fromTable Security = "security"
 
-data Chain = INPUT | OUTPUT | FORWARD
+data Target = ACCEPT | REJECT | DROP | LOG | TargetCustom String
 	deriving (Eq, Show)
 
-data TargetFilter = ACCEPT | REJECT | DROP | LOG | FilterCustom String
+fromTarget :: Target -> String
+fromTarget ACCEPT = "ACCEPT"
+fromTarget REJECT = "REJECT"
+fromTarget DROP = "DROP"
+fromTarget LOG = "LOG"
+fromTarget (TargetCustom t) = t
+
+data Chain = ChainFilter | ChainNat | ChainMangle | ChainRaw | ChainSecurity
 	deriving (Eq, Show)
 
-class FromTarget a where
-	fromTarget :: a -> String
+instance FromChain Chain where
+	fromChain = fromChain
+
+class FromChain a where
+	fromChain :: a -> String
+
+data ChainFilter = INPUT | OUTPUT | FORWARD | FilterCustom String
+	deriving (Eq, Show)
 
-instance FromTarget TargetFilter where
-	fromTarget ACCEPT = "ACCEPT"
-	fromTarget REJECT = "REJECT"
-	fromTarget DROP = "DROP"
-	fromTarget LOG = "LOG"
-	fromTarget (FilterCustom f) = f
+instance FromChain ChainFilter where
+	fromChain INPUT = "INPUT"
+	fromChain OUTPUT = "OUTPUT"
+	fromChain FORWARD = "FORWARD"
+	fromChain (FilterCustom c) = c
 
-data TargetNat = NatPREROUTING | NatOUTPUT | NatPOSTROUTING | NatCustom String
+data ChainNat = NatPREROUTING | NatOUTPUT | NatPOSTROUTING | NatCustom String
 	deriving (Eq, Show)
 
-instance FromTarget TargetNat where
-	fromTarget NatPREROUTING = "PREROUTING"
-	fromTarget NatOUTPUT = "OUTPUT"
-	fromTarget NatPOSTROUTING = "POSTROUTING"
-	fromTarget (NatCustom f) = f
+instance FromChain ChainNat where
+	fromChain NatPREROUTING = "PREROUTING"
+	fromChain NatOUTPUT = "OUTPUT"
+	fromChain NatPOSTROUTING = "POSTROUTING"
+	fromChain (NatCustom f) = f
 
-data TargetMangle = ManglePREROUTING | MangleOUTPUT | MangleINPUT | MangleFORWARD | ManglePOSTROUTING | MangleCustom String
+data ChainMangle = ManglePREROUTING | MangleOUTPUT | MangleINPUT | MangleFORWARD | ManglePOSTROUTING | MangleCustom String
 	deriving (Eq, Show)
 
-instance FromTarget TargetMangle where
-	fromTarget ManglePREROUTING = "PREROUTING"
-	fromTarget MangleOUTPUT = "OUTPUT"
-	fromTarget MangleINPUT = "INPUT"
-	fromTarget MangleFORWARD = "FORWARD"
-	fromTarget ManglePOSTROUTING = "POSTROUTING"
-	fromTarget (MangleCustom f) = f
+instance FromChain ChainMangle where
+	fromChain ManglePREROUTING = "PREROUTING"
+	fromChain MangleOUTPUT = "OUTPUT"
+	fromChain MangleINPUT = "INPUT"
+	fromChain MangleFORWARD = "FORWARD"
+	fromChain ManglePOSTROUTING = "POSTROUTING"
+	fromChain (MangleCustom f) = f
 
-data TargetRaw = RawPREROUTING | RawOUTPUT | RawCustom String
+data ChainRaw = RawPREROUTING | RawOUTPUT | RawCustom String
 	deriving (Eq, Show)
 
-instance FromTarget TargetRaw where
-	fromTarget RawPREROUTING = "PREROUTING"
-	fromTarget RawOUTPUT = "OUTPUT"
-	fromTarget (RawCustom f) = f
+instance FromChain ChainRaw where
+	fromChain RawPREROUTING = "PREROUTING"
+	fromChain RawOUTPUT = "OUTPUT"
+	fromChain (RawCustom f) = f
 
-data TargetSecurity = SecurityINPUT | SecurityOUTPUT | SecurityFORWARD | SecurityCustom String
+data ChainSecurity = SecurityINPUT | SecurityOUTPUT | SecurityFORWARD | SecurityCustom String
 	deriving (Eq, Show)
 
-instance FromTarget TargetSecurity where
-	fromTarget SecurityINPUT = "INPUT"
-	fromTarget SecurityOUTPUT = "OUTPUT"
-	fromTarget SecurityFORWARD = "FORWARD"
-	fromTarget (SecurityCustom f) = f
+instance FromChain ChainSecurity where
+	fromChain SecurityINPUT = "INPUT"
+	fromChain SecurityOUTPUT = "OUTPUT"
+	fromChain SecurityFORWARD = "FORWARD"
+	fromChain (SecurityCustom f) = f
 
 data Proto = TCP | UDP | ICMP
 	deriving (Eq, Show)
@@ -159,6 +184,26 @@ data Proto = TCP | UDP | ICMP
 data ConnectionState = ESTABLISHED | RELATED | NEW | INVALID
 	deriving (Eq, Show)
 
+data ICMPTypeMatch = ICMPTypeName String | ICMPTypeCode Int
+	deriving (Eq, Show)
+
+fromICMPTypeMatch :: ICMPTypeMatch -> String
+fromICMPTypeMatch (ICMPTypeName t) = t
+fromICMPTypeMatch (ICMPTypeCode c) = show c
+
+data Frequency = NumBySecond Int
+	deriving (Eq, Show)
+
+fromFrequency :: Frequency -> String
+fromFrequency (NumBySecond n) = show n ++ "/second"
+
+type TCPFlagMask = [TCPFlag]
+
+type TCPFlagComp = [TCPFlag]
+
+data TCPFlag = SYN | ACK | FIN | RST | URG | PSH | ALL | NONE
+	deriving (Eq, Show)
+
 data Rules
 	= Everything
 	| Proto Proto
@@ -169,6 +214,10 @@ data Rules
 	| InIFace Network.Interface
 	| OutIFace Network.Interface
 	| Ctstate [ ConnectionState ]
+	| ICMPType ICMPTypeMatch
+	| RateLimit Frequency
+	| TCPFlags TCPFlagMask TCPFlagComp
+	| TCPSyn
 	| Source [ IPWithMask ]
 	| Destination [ IPWithMask ]
 	| Rules :- Rules   -- ^Combine two rules