From 6bb39d0125c8b1cb65eb33cb04fb300601fd4f93 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Mar 2016 14:47:46 -0400 Subject: avoid repeated rebuilds, more type safely buildFirst re-runs propellor with --continue, which is supposed to make defaultMain bypass subsequent calls to buildFirst. But, use of a Bool to do that caused the code to be unclear, and some of the cases lost track of that. --continue SimpleRun would buildFirst, and if the binary changed, would --continue SimpleRun. This could loop repatedly, on systems such as FreeBSD where building re-links the binary even when there are no changes. As discussed in github pull #11 Fixed by introducing a CanRebuild data type, which buildFirst and updateFirst require in order to do any work makes it more clear what's going on. It's not a type-level proof that propellor won't rebuild repeatedly, but gets closer to one. (Only remaining way such a bug could slip in is if the CanRebuild value was reused in a call to buildFirst and also inside the IO action passed to it.) There were some other weirdnesses around repeated builds. In particular, Run as non-root did an updateFirst, followed by a buildFirst. I think this redundant build was an accident, and have removed it. --- src/Propellor/CmdLine.hs | 51 +++++++++++++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 20 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 6d9db8bf..a5ea1f1c 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,22 +113,27 @@ 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) + ( onlyprocess $ withhost hn mainProperties + , go cr (Spin [hn] Nothing) + ) + go cr (SimpleRun hn) = go cr (Run hn) + go cr (Continue cmdline@(SimpleRun _)) = + -- --continue SimpleRun is used by --spin, + -- and unlike all other uses of --continue, this legacy one + -- wants an update first (to get any changes from the + -- central git repo) + forceConsole >> updateFirst cr cmdline (go NoRebuild cmdline) + -- 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) @@ -142,8 +148,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 +161,7 @@ buildFirst cmdline next = do ] where getmtime = catchMaybeIO $ getModificationTime "propellor" +buildFirst NoRebuild _ next = next fetchFirst :: IO () -> IO () fetchFirst next = do @@ -162,11 +169,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 +185,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. -- cgit v1.2.3 From d514079f83ee6c60fb1cd0613dbe5145eff4d403 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Mar 2016 15:07:25 -0400 Subject: always buildFirst when --spin does --continue SimpleRun There may not be changes from the origin repo, so fetchFirst wouldn't build, but changes are pushed by spin, so it always needs to build. --- src/Propellor/CmdLine.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index a5ea1f1c..a0ae9cb5 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -122,22 +122,23 @@ defaultMain hostlist = withConcurrentOutput $ do forM_ hs $ \hn -> withhost hn $ spin mrelay hn go cr (Run hn) = fetchFirst $ ifM ((==) 0 <$> getRealUserID) - ( onlyprocess $ withhost hn mainProperties + ( runhost hn , go cr (Spin [hn] Nothing) ) - go cr (SimpleRun hn) = go cr (Run hn) - go cr (Continue cmdline@(SimpleRun _)) = + 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 an update first (to get any changes from the - -- central git repo) - forceConsole >> updateFirst cr cmdline (go NoRebuild cmdline) + -- 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 -- cgit v1.2.3 From 3abf0af94cd7cf4d0c0666a40deff43ca590a597 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Mon, 29 Feb 2016 08:59:58 +0100 Subject: Firewall: separate Table and Target (cherry picked from commit c97f1308739aa7877aac2f3c949c4aadf2266775) --- src/Propellor/Property/Firewall.hs | 125 +++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 60 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index eefc8342..62adf33a 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -7,11 +7,7 @@ module Propellor.Property.Firewall ( installed, Chain(..), Table(..), - TargetFilter(..), - TargetNat(..), - TargetMangle(..), - TargetRaw(..), - TargetSecurity(..), + Target(..), Proto(..), Rules(..), ConnectionState(..), @@ -30,10 +26,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 +41,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 = [] @@ -80,78 +77,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) -- cgit v1.2.3 From 60a7dfeb65b72e2ef26e071c007f9d11fe9aebc2 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Mon, 29 Feb 2016 09:20:24 +0100 Subject: Firewall: add ICMPTypeMatch (cherry picked from commit 2214aca8f3ca92b9739b2884cb59274edad9170e) --- src/Propellor/Property/Firewall.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index 62adf33a..05d70f45 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -11,6 +11,7 @@ module Propellor.Property.Firewall ( Proto(..), Rules(..), ConnectionState(..), + ICMPTypeMatch(..), IPWithMask(..), fromIPWithMask ) where @@ -58,6 +59,11 @@ toIpTableArg (Ctstate states) = , "conntrack" , "--ctstate", intercalate "," (map show states) ] +toIpTableArg (ICMPType i) = + [ "-m" + , "icmp" + , "--icmp-type", fromICMPTypeMatch i + ] toIpTableArg (Source ipwm) = [ "-s" , intercalate "," (map fromIPWithMask ipwm) @@ -164,6 +170,13 @@ 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 Rules = Everything | Proto Proto @@ -174,6 +187,7 @@ data Rules | InIFace Network.Interface | OutIFace Network.Interface | Ctstate [ ConnectionState ] + | ICMPType ICMPTypeMatch | Source [ IPWithMask ] | Destination [ IPWithMask ] | Rules :- Rules -- ^Combine two rules -- cgit v1.2.3 From 02edd1dca9b5554728201924a8ed786133b1c57d Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Mon, 29 Feb 2016 09:48:46 +0100 Subject: Firewall: add Frequency (cherry picked from commit 26fd68a9cda543e74492dc71680d10eaa881f351) --- src/Propellor/Property/Firewall.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index 05d70f45..01664130 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -12,6 +12,7 @@ module Propellor.Property.Firewall ( Rules(..), ConnectionState(..), ICMPTypeMatch(..), + Frequency(..), IPWithMask(..), fromIPWithMask ) where @@ -64,6 +65,11 @@ toIpTableArg (ICMPType i) = , "icmp" , "--icmp-type", fromICMPTypeMatch i ] +toIpTableArg (RateLimit f) = + [ "-m" + , "limit" + , "--limit", fromFrequency f + ] toIpTableArg (Source ipwm) = [ "-s" , intercalate "," (map fromIPWithMask ipwm) @@ -177,6 +183,12 @@ 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" + data Rules = Everything | Proto Proto @@ -188,6 +200,7 @@ data Rules | OutIFace Network.Interface | Ctstate [ ConnectionState ] | ICMPType ICMPTypeMatch + | RateLimit Frequency | Source [ IPWithMask ] | Destination [ IPWithMask ] | Rules :- Rules -- ^Combine two rules -- cgit v1.2.3 From 140fb642e8ea3492313d3f41ef44930e1974b3f9 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Mon, 29 Feb 2016 18:03:12 +0100 Subject: Firewall: add TCPFlag (cherry picked from commit f16e0e4f632032c70adcb9ba9f108e87a6ae4321) --- src/Propellor/Property/Firewall.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index 01664130..bf41cf20 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -70,6 +70,13 @@ toIpTableArg (RateLimit f) = , "limit" , "--limit", fromFrequency f ] +toIpTableArg (TCPFlags m c) = + [ "-m" + , "tcp" + , "--tcp-flags" + , intercalate "," (map show m) + , intercalate "," (map show c) + ] toIpTableArg (Source ipwm) = [ "-s" , intercalate "," (map fromIPWithMask ipwm) @@ -189,6 +196,13 @@ data Frequency = NumBySecond Int 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 @@ -201,6 +215,7 @@ data Rules | Ctstate [ ConnectionState ] | ICMPType ICMPTypeMatch | RateLimit Frequency + | TCPFlags TCPFlagMask TCPFlagComp | Source [ IPWithMask ] | Destination [ IPWithMask ] | Rules :- Rules -- ^Combine two rules -- cgit v1.2.3 From 91cc571b2d6947acd70717157cd1b24819202997 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Mon, 29 Feb 2016 18:05:24 +0100 Subject: Firewall: add TCPSyn to Rules (cherry picked from commit 864bff7743bd3a77f1bfdb37bdeeea49e31e1f52) --- src/Propellor/Property/Firewall.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index bf41cf20..c4d2ee1b 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -77,6 +77,7 @@ toIpTableArg (TCPFlags m c) = , intercalate "," (map show m) , intercalate "," (map show c) ] +toIpTableArg TCPSyn = ["--syn"] toIpTableArg (Source ipwm) = [ "-s" , intercalate "," (map fromIPWithMask ipwm) @@ -216,6 +217,7 @@ data Rules | ICMPType ICMPTypeMatch | RateLimit Frequency | TCPFlags TCPFlagMask TCPFlagComp + | TCPSyn | Source [ IPWithMask ] | Destination [ IPWithMask ] | Rules :- Rules -- ^Combine two rules -- cgit v1.2.3