From 56c3394144abbb9862dc67379d3253c76ae4df97 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 14:34:10 -0400 Subject: Explicit Info/NoInfo for RevertableProperty (API change) RevertableProperty used to be assumed to contain info, but this is now made explicit, with RevertableProperty HasInfo or RevertableProperty NoInfo. Transition guide: - If you define a RevertableProperty, expect some type check failures like: "Expecting one more argument to ‘RevertableProperty’". - Change it to "RevertableProperty NoInfo" - The compiler will then tell you if it needs "HasInfo" instead. - If you have code that uses the RevertableProperty constructor that fails to type check, use the more powerful operator --- src/Propellor/PropAccum.hs | 4 +- src/Propellor/Property.hs | 2 +- src/Propellor/Property/Apache.hs | 6 +- src/Propellor/Property/Apt.hs | 4 +- src/Propellor/Property/Chroot.hs | 4 +- src/Propellor/Property/Conductor.hs | 6 +- src/Propellor/Property/Debootstrap.hs | 2 +- src/Propellor/Property/DiskImage.hs | 8 +- src/Propellor/Property/Dns.hs | 8 +- src/Propellor/Property/DnsSec.hs | 4 +- src/Propellor/Property/Docker.hs | 2 +- src/Propellor/Property/Git.hs | 2 +- src/Propellor/Property/Nginx.hs | 2 +- src/Propellor/Property/Prosody.hs | 2 +- src/Propellor/Property/SiteSpecific/JoeySites.hs | 4 +- src/Propellor/Property/Ssh.hs | 2 +- src/Propellor/Property/Systemd.hs | 22 ++-- src/Propellor/Property/Uwsgi.hs | 2 +- src/Propellor/Types.hs | 130 ++++++++++++++++------- 19 files changed, 135 insertions(+), 81 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 3c50cf32..85a30af5 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, FlexibleContexts #-} module Propellor.PropAccum ( host @@ -46,7 +46,7 @@ class PropAccum h where (&^) = addPropFront -- | Adds a property in reverted form. -(!) :: PropAccum h => h -> RevertableProperty -> h +(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h h ! p = h & revert p infixl 1 & diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index d80d9c1f..e967cac9 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -201,7 +201,7 @@ withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS -- | Undoes the effect of a RevertableProperty. -revert :: RevertableProperty -> RevertableProperty +revert :: RevertableProperty i -> RevertableProperty i revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 makeChange :: IO () -> Propellor Result diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index 91b2e6a2..c2f49cff 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -16,7 +16,7 @@ reloaded = Service.reloaded "apache2" -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. -virtualHost :: HostName -> Port -> FilePath -> RevertableProperty +virtualHost :: HostName -> Port -> FilePath -> RevertableProperty NoInfo virtualHost hn (Port p) docroot = siteEnabled hn [ "" , "ServerName "++hn++":"++show p @@ -30,7 +30,7 @@ virtualHost hn (Port p) docroot = siteEnabled hn type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable disable where enable = combineProperties ("apache site enabled " ++ hn) @@ -59,7 +59,7 @@ siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ where comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty +modEnabled :: String -> RevertableProperty NoInfo modEnabled modname = enable disable where enable = check (not <$> isenabled) $ diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 14f170af..fd6230e8 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -212,7 +212,7 @@ autoRemove = runApt ["-y", "autoremove"] `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. -unattendedUpgrades :: RevertableProperty +unattendedUpgrades :: RevertableProperty NoInfo unattendedUpgrades = enable disable where enable = setup True @@ -272,7 +272,7 @@ data AptKey = AptKey , pubkey :: String } -trustsKey :: AptKey -> RevertableProperty +trustsKey :: AptKey -> RevertableProperty NoInfo trustsKey k = trustsKey' k untrustKey k trustsKey' :: AptKey -> Property NoInfo diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 771c4b99..20871a12 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -116,10 +116,10 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty +provisioned :: Chroot -> RevertableProperty HasInfo provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty +provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propigator $ propertyList (chrootDesc c "exists") [setup]) diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ed46601d..0d275b91 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,7 +83,7 @@ import qualified Data.Set as S -- | Class of things that can be conducted. class Conductable c where - conducts :: c -> RevertableProperty + conducts :: c -> RevertableProperty HasInfo instance Conductable Host where -- | Conduct the specified host. @@ -268,7 +268,7 @@ notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotCond where desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty +conductorKnownHost :: Host -> RevertableProperty NoInfo conductorKnownHost h = mk Ssh.knownHost @@ -290,7 +290,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. -conductedBy :: Host -> RevertableProperty +conductedBy :: Host -> RevertableProperty NoInfo conductedBy h = (setup teardown) `describe` ("conducted by " ++ hostName h) where diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index f8981591..61912b32 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -98,7 +98,7 @@ extractSuite (System (Ubuntu r) _) = Just r -- When necessary, falls back to installing debootstrap from source. -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification. -installed :: RevertableProperty +installed :: RevertableProperty NoInfo installed = install remove where install = withOS "debootstrap installed" $ \o -> diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 90d0bcc6..5b8619ba 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -69,16 +69,16 @@ type DiskImage = FilePath -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot @@ -99,7 +99,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = & Apt.cacheCleaned -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 4c2f787f..adc12930 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -60,7 +60,7 @@ import Data.List -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. -primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs @@ -152,7 +152,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger. -signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo signedPrimary recurrance hosts domain soa rs = setup cleanup where setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") @@ -184,12 +184,12 @@ signedPrimary recurrance hosts domain soa rs = setup cleanup -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins. -secondary :: [Host] -> Domain -> RevertableProperty +secondary :: [Host] -> Domain -> RevertableProperty HasInfo secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. -secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs index c0aa1302..1ba459e6 100644 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -7,7 +7,7 @@ import qualified Propellor.Property.File as File -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -keysInstalled :: Domain -> RevertableProperty +keysInstalled :: Domain -> RevertableProperty HasInfo keysInstalled domain = setup cleanup where setup = propertyList "DNSSEC keys installed" $ @@ -37,7 +37,7 @@ keysInstalled domain = setup cleanup -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -zoneSigned :: Domain -> FilePath -> RevertableProperty +zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo zoneSigned domain zonefile = setup cleanup where setup = check needupdate (forceZoneSigned domain zonefile) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 394c4271..2b0e7e7e 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -123,7 +123,7 @@ container cn image = Container image (Host cn [] info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked :: Container -> RevertableProperty +docked :: Container -> RevertableProperty HasInfo docked ctr@(Container _ h) = (propagateContainerInfo ctr (go "docked" setup)) diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index d69fe250..8937d21a 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -11,7 +11,7 @@ import Data.List -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty +daemonRunning :: FilePath -> RevertableProperty NoInfo daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index c9b4d8fd..c28dcc01 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty +siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable disable where enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 0e379e63..f2d80ae4 100644 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type Conf = String -confEnabled :: Conf -> ConfigFile -> RevertableProperty +confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo confEnabled conf cf = enable disable where enable = dir `File.isSymlinkedTo` target diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 92903e9a..d6db6813 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -298,7 +298,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , " " ] -apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile @@ -921,7 +921,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "rewriterule (.*) http://joeyh.name$1 [r]" ] -userDirHtml :: Property HasInfo +userDirHtml :: Property NoInfo userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded `requires` Apache.modEnabled "userdir" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 60121336..304ed5cc 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -115,7 +115,7 @@ dotFile f user = do -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Int -> RevertableProperty +listenPort :: Int -> RevertableProperty NoInfo listenPort port = enable disable where portline = "Port " ++ show port diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 8761d842..42ff8e57 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -93,7 +93,7 @@ disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") -- | Masks a systemd service. -masked :: ServiceName -> RevertableProperty +masked :: ServiceName -> RevertableProperty NoInfo masked n = systemdMask systemdUnmask where systemdMask = trivial $ cmdProperty "systemctl" ["mask", n] @@ -206,7 +206,7 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty +nspawned :: Container -> RevertableProperty HasInfo nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where @@ -231,7 +231,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- | Sets up the service file for the container, and then starts -- it running. -nspawnService :: Container -> ChrootCfg -> RevertableProperty +nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name @@ -282,7 +282,7 @@ nspawnServiceParams (SystemdNspawnCfg ps) = -- -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace. -enterScript :: Container -> RevertableProperty +enterScript :: Container -> RevertableProperty NoInfo enterScript c@(Container name _ _) = setup teardown where setup = combineProperties ("generated " ++ enterScriptFile c) @@ -328,7 +328,7 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty +containerCfg :: String -> RevertableProperty HasInfo containerCfg p = RevertableProperty (mk True) (mk False) where mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ @@ -340,18 +340,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty +resolvConfed :: RevertableProperty HasInfo resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty +linkJournal :: RevertableProperty HasInfo linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty +privateNetwork :: RevertableProperty HasInfo privateNetwork = containerCfg "private-network" class Publishable a where @@ -389,7 +389,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty +publish :: Publishable p => p -> RevertableProperty HasInfo publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -402,9 +402,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty +bind :: Bindable p => p -> RevertableProperty HasInfo bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty +bindRo :: Bindable p => p -> RevertableProperty HasInfo bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs index 7de1a85a..9748f16d 100644 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type AppName = String -appEnabled :: AppName -> ConfigFile -> RevertableProperty +appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo appEnabled an cf = enable disable where enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 06f0935d..fa24786c 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -156,12 +156,6 @@ propertySatisfy :: Property i -> Propellor Result propertySatisfy (IProperty _ a _ _) = a propertySatisfy (SProperty _ a _) = a -instance Show (Property i) where - show p = "property " ++ show (propertyDesc p) - -instance Show RevertableProperty where - show (RevertableProperty p _) = "property " ++ show (propertyDesc p) - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs @@ -175,6 +169,9 @@ propertyDesc :: Property i -> Desc propertyDesc (IProperty d _ _ _) = d propertyDesc (SProperty d _ _) = d +instance Show (Property i) where + show p = "property " ++ show (propertyDesc p) + -- | A Property can include a list of child properties that it also -- satisfies. This allows them to be introspected to collect their info, etc. propertyChildren :: Property i -> [Property i] @@ -183,11 +180,23 @@ propertyChildren (SProperty _ _ cs) = cs -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo) +data RevertableProperty i = RevertableProperty (Property i) (Property i) + +instance Show (RevertableProperty i) where + show (RevertableProperty p _) = show p --- | Shorthand to construct a revertable property. -() :: Property i1 -> Property i2 -> RevertableProperty -p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2) +class MkRevertableProperty i1 i2 where + -- | Shorthand to construct a revertable property. + () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) + +instance MkRevertableProperty HasInfo HasInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo NoInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo HasInfo where + x y = RevertableProperty (toProp x) y +instance MkRevertableProperty HasInfo NoInfo where + x y = RevertableProperty x (toProp y) -- | Class of types that can be used as properties of a host. class IsProp p where @@ -210,35 +219,43 @@ instance IsProp (Property NoInfo) where getDesc = propertyDesc getInfoRecursive _ = mempty -instance IsProp RevertableProperty where - -- | Sets the description of both sides. - setDesc (RevertableProperty p1 p2) d = - RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) +instance IsProp (RevertableProperty HasInfo) where + setDesc = setDescR getDesc (RevertableProperty p1 _) = getDesc p1 toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 +instance IsProp (RevertableProperty NoInfo) where + setDesc = setDescR + getDesc (RevertableProperty p1 _) = getDesc p1 + toProp (RevertableProperty p1 _) = toProp p1 + getInfoRecursive (RevertableProperty _ _) = mempty + +-- | Sets the description of both sides. +setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i +setDescR (RevertableProperty p1 p2) d = + RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty +type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) -- When only one of the properties is revertable, the combined property is -- not fully revertable, so is not a RevertableProperty. -type instance CombinedType RevertableProperty (Property NoInfo) = Property HasInfo -type instance CombinedType RevertableProperty (Property HasInfo) = Property HasInfo -type instance CombinedType (Property NoInfo) RevertableProperty = Property HasInfo -type instance CombinedType (Property HasInfo) RevertableProperty = Property HasInfo +type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y) +type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) + +type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result class Combines x y where -- | Combines together two properties, yielding a property that -- has the description and info of the first, and that has the second -- property as a child. combineWith - :: (Propellor Result -> Propellor Result -> Propellor Result) + :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. - -> (Propellor Result -> Propellor Result -> Propellor Result) + -> ResultCombiner -- ^ Used when combining revertable properties, to combine -- their reversion actions. -> x @@ -261,20 +278,57 @@ instance Combines (Property NoInfo) (Property NoInfo) where combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = SProperty d1 (f a1 a2) (y : cs1) -instance Combines RevertableProperty RevertableProperty where - combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = - RevertableProperty - (combineWith sf tf s1 s2) - (combineWith tf sf t1 t2) - -instance Combines RevertableProperty (Property HasInfo) where - combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y - -instance Combines RevertableProperty (Property NoInfo) where - combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y - -instance Combines (Property HasInfo) RevertableProperty where - combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y - -instance Combines (Property NoInfo) RevertableProperty where - combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y +instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty NoInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (Property HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR + +combineWithRR + :: Combines (Property x) (Property y) + => ResultCombiner + -> ResultCombiner + -> RevertableProperty x + -> RevertableProperty y + -> RevertableProperty (CInfo x y) +combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) + +combineWithRP + :: Combines (Property i) y + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> RevertableProperty i + -> y + -> CombinedType (Property i) y +combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y + +combineWithPR + :: Combines x (Property i) + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> x + -> RevertableProperty i + -> CombinedType x (Property i) +combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y -- cgit v1.2.3 From 6e3b0022fa451181fdce8abd145e27a64a777711 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 16:19:15 -0400 Subject: use a shared global for the MessageHandle --- src/Propellor/Engine.hs | 3 +- src/Propellor/Message.hs | 69 +++++++++++++++++++--------------------- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Docker.hs | 2 +- 4 files changed, 36 insertions(+), 40 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index a811724a..f0bcdac8 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -38,8 +38,7 @@ mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] - h <- mkMessageHandle - whenConsole h $ + whenConsole $ setTitle "propellor: done" hFlush stdout case ret of diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 94892da8..9c6cb57c 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -9,10 +9,11 @@ import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import "mtl" Control.Monad.Reader -import Data.Maybe import Control.Applicative import System.Directory import Control.Monad.IfElse +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent import Propellor.Types import Utility.Monad @@ -20,27 +21,26 @@ import Utility.Env import Utility.Process import Utility.Exception -data MessageHandle - = ConsoleMessageHandle - | TextMessageHandle +data MessageHandle = MessageHandle + { isConsole :: Bool + } -mkMessageHandle :: IO MessageHandle -mkMessageHandle = do - ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) - ( return ConsoleMessageHandle - , return TextMessageHandle - ) +-- | A shared global variable for the MessageHandle. +{-# NOINLINE globalMessageHandle #-} +globalMessageHandle :: MVar MessageHandle +globalMessageHandle = unsafePerformIO $ do + c <- hIsTerminalDevice stdout + newMVar $ MessageHandle c -forceConsole :: IO () -forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True +getMessageHandle :: IO MessageHandle +getMessageHandle = readMVar globalMessageHandle -isConsole :: MessageHandle -> Bool -isConsole ConsoleMessageHandle = True -isConsole _ = False +forceConsole :: IO () +forceConsole = modifyMVar_ globalMessageHandle $ \mh -> + pure (mh { isConsole = True }) -whenConsole :: MessageHandle -> IO () -> IO () -whenConsole ConsoleMessageHandle a = a -whenConsole _ _ = return () +whenConsole :: IO () -> IO () +whenConsole a = whenM (isConsole <$> getMessageHandle) a -- | Shows a message while performing an action, with a colored status -- display. @@ -54,49 +54,46 @@ actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - h <- liftIO mkMessageHandle - liftIO $ whenConsole h $ do + liftIO $ whenConsole $ do setTitle $ "propellor: " ++ desc hFlush stdout r <- a liftIO $ do - whenConsole h $ + whenConsole $ setTitle "propellor: running" - showhn h mhn + showhn mhn putStr $ desc ++ " ... " let (msg, intensity, color) = getActionResult r - colorLine h intensity color msg + colorLine intensity color msg hFlush stdout return r where - showhn _ Nothing = return () - showhn h (Just hn) = do - whenConsole h $ + showhn Nothing = return () + showhn (Just hn) = do + whenConsole $ setSGR [SetColor Foreground Dull Cyan] putStr (hn ++ " ") - whenConsole h $ + whenConsole $ setSGR [] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + colorLine Vivid Magenta $ "** warning: " ++ s errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Red $ "** error: " ++ s + colorLine Vivid Red $ "** error: " ++ s error "Cannot continue!" -colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO () -colorLine h intensity color msg = do - whenConsole h $ +colorLine :: ColorIntensity -> Color -> String -> IO () +colorLine intensity color msg = do + whenConsole $ setSGR [SetColor Foreground intensity color] putStr msg - whenConsole h $ + whenConsole $ setSGR [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 20871a12..8b923aab 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -193,7 +193,7 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr toChain :: HostName -> Chroot -> Bool -> IO CmdLine toChain parenthost (Chroot loc _ _) systemdonly = do - onconsole <- isConsole <$> mkMessageHandle + onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole chain :: [Host] -> CmdLine -> IO () diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 2b0e7e7e..5f41209a 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -555,7 +555,7 @@ provisionContainer :: ContainerId -> Property NoInfo provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ toChain cid] - msgh <- mkMessageHandle + msgh <- getMessageHandle let p = inContainerProcess cid (if isConsole msgh then ["-it"] else []) (shim : params) -- cgit v1.2.3 From 20b04d366b2cff90c39d06fd424ae3e8b67e49f6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 17:02:23 -0400 Subject: make Propellor.Message use lock to handle concurrent threads outputting messages Not yet handled: Output from concurrent programs. --- debian/changelog | 2 +- src/Propellor/Engine.hs | 33 +------------ src/Propellor/Message.hs | 92 ++++++++++++++++++++++++++++++++---- src/Propellor/PrivData.hs | 22 +++++---- src/Propellor/Property/Concurrent.hs | 4 +- 5 files changed, 100 insertions(+), 53 deletions(-) (limited to 'src/Propellor') diff --git a/debian/changelog b/debian/changelog index 6b3f6940..1699b27b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * combineWith now takes an additional parameter to control how revert actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. - (Note that no output multiplexing is currently done.) + (Note that no command output multiplexing is currently done.) * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index f0bcdac8..36a05b28 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -9,14 +9,12 @@ module Propellor.Engine ( fromHost, fromHost', onlyProcess, - processChainOutput, ) where import System.Exit import System.IO import Data.Monoid import Control.Applicative -import System.Console.ANSI import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO @@ -29,8 +27,6 @@ import Propellor.Exception import Propellor.Info import Propellor.Property import Utility.Exception -import Utility.PartialPrelude -import Utility.Monad -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -38,9 +34,7 @@ mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] - whenConsole $ - setTitle "propellor: done" - hFlush stdout + messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess @@ -98,28 +92,3 @@ onlyProcess lockfile a = bracket lock unlock (const a) return l unlock = closeFd alreadyrunning = error "Propellor is already running on this host!" - --- | Reads and displays each line from the Handle, except for the last line --- which is a Result. -processChainOutput :: Handle -> IO Result -processChainOutput h = go Nothing - where - go lastline = do - v <- catchMaybeIO (hGetLine h) - debug ["read from chained propellor: ", show v] - case v of - Nothing -> case lastline of - Nothing -> do - debug ["chained propellor output nothing; assuming it failed"] - return FailedChange - Just l -> case readish l of - Just r -> pure r - Nothing -> do - debug ["chained propellor output did not end with a Result; assuming it failed"] - putStrLn l - hFlush stdout - return FailedChange - Just s -> do - maybe noop (\l -> unless (null l) (putStrLn l)) lastline - hFlush stdout - go (Just s) diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 9c6cb57c..0961a356 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,6 +1,26 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Message where +-- | This module handles all display of output to the console when +-- propellor is ensuring Properties. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. + +module Propellor.Message ( + getMessageHandle, + isConsole, + forceConsole, + actionMessage, + actionMessageOn, + warningMessage, + infoMessage, + errorMessage, + debug, + checkDebugMode, + enableDebugMode, + processChainOutput, + messagesDone, +) where import System.Console.ANSI import System.IO @@ -16,6 +36,7 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import Propellor.Types +import Utility.PartialPrelude import Utility.Monad import Utility.Env import Utility.Process @@ -23,6 +44,7 @@ import Utility.Exception data MessageHandle = MessageHandle { isConsole :: Bool + , outputLock :: MVar () } -- | A shared global variable for the MessageHandle. @@ -30,30 +52,44 @@ data MessageHandle = MessageHandle globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ do c <- hIsTerminalDevice stdout - newMVar $ MessageHandle c + o <- newMVar () + newMVar $ MessageHandle c o +-- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle +-- | Takes a lock while performing an action. Any other threads +-- that try to lockOutput at the same time will block. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput a = do + lck <- liftIO $ outputLock <$> getMessageHandle + bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a + +-- | Force console output. This can be used when stdout is not directly +-- connected to a console, but is eventually going to be displayed at a +-- console. forceConsole :: IO () forceConsole = modifyMVar_ globalMessageHandle $ \mh -> pure (mh { isConsole = True }) +-- | Only performs the action when at the console, or when console +-- output has been forced. whenConsole :: IO () -> IO () whenConsole a = whenM (isConsole <$> getMessageHandle) a -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r -actionMessage' mhn desc a = do +actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' mhn desc a = lockOutput $ do liftIO $ whenConsole $ do setTitle $ "propellor: " ++ desc hFlush stdout @@ -80,14 +116,18 @@ actionMessage' mhn desc a = do setSGR [] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ +warningMessage s = liftIO $ lockOutput $ colorLine Vivid Magenta $ "** warning: " ++ s +infoMessage :: MonadIO m => [String] -> m () +infoMessage ls = liftIO $ lockOutput $ + mapM_ putStrLn ls + errorMessage :: MonadIO m => String -> m a -errorMessage s = liftIO $ do +errorMessage s = liftIO $ lockOutput $ do colorLine Vivid Red $ "** error: " ++ s error "Cannot continue!" - + colorLine :: ColorIntensity -> Color -> String -> IO () colorLine intensity color msg = do whenConsole $ @@ -120,3 +160,37 @@ enableDebugMode = do <*> pure (simpleLogFormatter "[$time] $msg") updateGlobalLogger rootLoggerName $ setLevel DEBUG . setHandlers [f] + +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + debug ["read from chained propellor: ", show v] + case v of + Nothing -> case lastline of + Nothing -> do + debug ["chained propellor output nothing; assuming it failed"] + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + debug ["chained propellor output did not end with a Result; assuming it failed"] + lockOutput $ do + putStrLn l + hFlush stdout + return FailedChange + Just s -> do + lockOutput $ do + maybe noop (\l -> unless (null l) (putStrLn l)) lastline + hFlush stdout + go (Just s) + +-- | Called when all messages about properties have been printed. +messagesDone :: IO () +messagesDone = lockOutput $ do + whenConsole $ + setTitle "propellor: done" + hFlush stdout diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index aac37d14..e59f42c3 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -106,9 +106,9 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> missing = do Context cname <- mkHostContext hc <$> asks hostName warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" - liftIO $ putStrLn $ "Fix this by running:" - liftIO $ showSet $ - map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist + infoMessage $ + "Fix this by running:" : + showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange addinfo p = infoProperty (propertyDesc p) @@ -121,11 +121,14 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> fieldlist = map privDataField srclist hc = asHostContext c -showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO () -showSet l = forM_ l $ \(f, Context c, md) -> do - putStrLn $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" - maybe noop (\d -> putStrLn $ " " ++ d) md - putStrLn "" +showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String] +showSet = concatMap go + where + go (f, Context c, md) = catMaybes + [ Just $ " propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\" + , maybe Nothing (\d -> Just $ " " ++ d) md + , Just "" + ] addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v)) @@ -207,7 +210,8 @@ listPrivDataFields hosts = do showtable $ map mkrow missing section "How to set missing data:" - showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing + mapM_ putStrLn $ showSet $ + map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing where header = ["Field", "Context", "Used by"] mkrow k@(field, Context context) = diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index c57f5228..645a5dfd 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} --- | Note that this module does not yet arrange for any output multiplexing, --- so the output of concurrent properties will be scrambled together. +-- | Note that any output of commands run by +-- concurrent properties will be scrambled together. module Propellor.Property.Concurrent ( concurrently, -- cgit v1.2.3 From 51b397d0415e1efe1df412842ccb76d702140f50 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 23:19:41 -0400 Subject: concurrent version of createProcess Have not yet wired everything up to use this, that currently uses Utility.Process. --- src/Propellor/Message.hs | 213 +++++++++++++++++++++++++++++++++++++++--- src/Propellor/Property/Cmd.hs | 1 + 2 files changed, 201 insertions(+), 13 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 0961a356..afe551cf 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -20,10 +20,12 @@ module Propellor.Message ( enableDebugMode, processChainOutput, messagesDone, + createProcess, ) where import System.Console.ANSI import System.IO +import System.Posix.IO import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) @@ -34,26 +36,38 @@ import System.Directory import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent +import Control.Concurrent.Async +import Data.Maybe +import Data.Char +import Data.List +import Data.Monoid +import qualified Data.ByteString as B import Propellor.Types import Utility.PartialPrelude import Utility.Monad import Utility.Env -import Utility.Process import Utility.Exception +import qualified Utility.Process as P data MessageHandle = MessageHandle { isConsole :: Bool - , outputLock :: MVar () + , outputLock :: MVar () -- ^ empty when locked + , outputLockedBy :: MVar Locker } +data Locker + = GeneralLock + | ProcessLock P.ProcessHandle + -- | A shared global variable for the MessageHandle. {-# NOINLINE globalMessageHandle #-} globalMessageHandle :: MVar MessageHandle -globalMessageHandle = unsafePerformIO $ do - c <- hIsTerminalDevice stdout - o <- newMVar () - newMVar $ MessageHandle c o +globalMessageHandle = unsafePerformIO $ + newMVar =<< MessageHandle + <$> hIsTerminalDevice stdout + <*> newMVar () + <*> newEmptyMVar -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle @@ -62,9 +76,71 @@ getMessageHandle = readMVar globalMessageHandle -- | Takes a lock while performing an action. Any other threads -- that try to lockOutput at the same time will block. lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput a = do - lck <- liftIO $ outputLock <$> getMessageHandle - bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + lck <- outputLock <$> getMessageHandle + go =<< tryTakeMVar lck + where + -- lck was full, and we've emptied it, so we hold the lock now. + go (Just ()) = havelock + -- lck is empty, so someone else is holding the lock. + go Nothing = do + lcker <- outputLockedBy <$> getMessageHandle + v' <- tryTakeMVar lcker + case v' of + Just (ProcessLock h) -> + -- if process has exited, lock is stale + ifM (isJust <$> P.getProcessExitCode h) + ( havelock + , if block + then do + void $ P.waitForProcess h + havelock + else do + putMVar lcker (ProcessLock h) + return False + ) + Just GeneralLock -> do + putMVar lcker GeneralLock + whenblock waitlock + Nothing -> whenblock waitlock + + havelock = do + updateOutputLocker GeneralLock + return True + waitlock = do + -- Wait for current lock holder to relinquish + -- it and take the lock. + lck <- outputLock <$> getMessageHandle + takeMVar lck + havelock + whenblock a = if block then a else return False + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = do + lcker <- outputLockedBy <$> getMessageHandle + lck <- outputLock <$> getMessageHandle + takeMVar lcker + putMVar lck () + +-- | Only safe to call after takeOutputLock; updates the Locker. +updateOutputLocker :: Locker -> IO () +updateOutputLocker l = do + lcker <- outputLockedBy <$> getMessageHandle + void $ tryTakeMVar lcker + putMVar lcker l + modifyMVar_ lcker (const $ return l) -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a @@ -89,14 +165,14 @@ actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r -actionMessage' mhn desc a = lockOutput $ do - liftIO $ whenConsole $ do +actionMessage' mhn desc a = do + liftIO $ whenConsole $ lockOutput $ do setTitle $ "propellor: " ++ desc hFlush stdout r <- a - liftIO $ do + liftIO $ lockOutput $ do whenConsole $ setTitle "propellor: running" showhn mhn @@ -151,7 +227,7 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" go Nothing = whenM (doesDirectoryExist ".git") $ whenM (elem "1" . lines <$> getgitconfig) enableDebugMode getgitconfig = catchDefaultIO "" $ - readProcess "git" ["config", "propellor.debug"] + P.readProcess "git" ["config", "propellor.debug"] enableDebugMode :: IO () enableDebugMode = do @@ -194,3 +270,114 @@ messagesDone = lockOutput $ do whenConsole $ setTitle "propellor: done" hFlush stdout + +-- | Wrapper around `System.Process.createProcess` that prevents processes +-- that are running concurrently from writing to the stdout/stderr at the +-- same time. +-- +-- The first process run by createProcess is allowed to write to +-- stdout and stderr in the usual way. +-- +-- However, if a second createProcess runs concurrently with the +-- first, any stdout or stderr that would have been displayed by it is +-- instead buffered. The buffered output will be displayed the next time it +-- is safe to do so (ie, after the first process exits). +-- +-- `Propellor.Property.Cmd` has some other useful actions for running +-- commands, which are based on this. +-- +-- Also does debug logging of all commands run. +createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcess p + | hasoutput (P.std_out p) || hasoutput (P.std_err p) = + ifM tryTakeOutputLock + ( firstprocess + , concurrentprocess + ) + | otherwise = P.createProcess p + where + hasoutput P.Inherit = True + hasoutput _ = False + + firstprocess = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + updateOutputLocker (ProcessLock h) + -- Output lock is still held as we return; the process + -- is running now, and once it exits the output lock will + -- be stale and can then be taken by something else. + return r + + concurrentprocess = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = if hasoutput (P.std_out p) + then P.UseHandle toouth + else P.std_out p + , P.std_err = if hasoutput (P.std_err p) + then P.UseHandle toerrh + else P.std_err p + } + r@(_, _, _, ph) <- P.createProcess p' + hClose toouth + hClose toerrh + buf <- newMVar [] + void $ async $ outputDrainer fromouth stdout buf + void $ async $ outputDrainer fromouth stderr buf + void $ async $ bufferWriter buf + return r + + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + +type Buffer = [(Handle, Maybe B.ByteString)] + +-- Drain output from the handle, and buffer it in memory. +outputDrainer :: Handle -> Handle -> MVar Buffer -> IO () +outputDrainer fromh toh buf = do + v <- tryIO $ B.hGetSome fromh 1024 + case v of + Right b | not (B.null b) -> do + modifyMVar_ buf (pure . addBuffer (toh, Just b)) + outputDrainer fromh toh buf + _ -> do + modifyMVar_ buf (pure . (++ [(toh, Nothing)])) + hClose fromh + +-- Wait to lock output, and once we can, display everything +-- that's put into buffer, until the end is signaled by Nothing +-- for both stdout and stderr. +bufferWriter buf = lockOutput (go [stdout, stderr]) + where + go [] = return () + go hs = do + l <- takeMVar buf + forM_ l $ \(h, mb) -> do + maybe noop (B.hPut h) mb + hFlush h + let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs + putMVar buf [] + go hs' + +-- The buffer can grow up to 1 mb in size, but after that point, +-- it's truncated to avoid propellor using unbounded memory +-- when a process outputs a whole lot of stuff. +bufsz = 1000000 + +addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer +addBuffer v@(_, Nothing) buf = buf ++ [v] +addBuffer (toh, Just b) buf = (toh, Just b') : other + where + (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf + b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b + +-- Truncate a buffer by removing lines from the front until it's +-- small enough. +truncateBuffer :: B.ByteString -> B.ByteString +truncateBuffer b + | B.length b <= bufsz = b + | otherwise = truncateBuffer $ snd $ B.breakByte nl b + where + nl = fromIntegral (ord '\n') diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 23816a94..f2c5b33e 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -16,6 +16,7 @@ module Propellor.Property.Cmd ( safeSystemEnv, shellEscape, createProcess, + waitForProcess, ) where import Control.Applicative -- cgit v1.2.3 From 894e2f7980052f1c331ba7780100ae0ad19856cb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 23:52:02 -0400 Subject: use execProcessConcurrent everywhere Found a reasonable clean way to make Utility.Process use execProcessConcurrent, while still allowing copying updates to it from git-annex. --- propellor.cabal | 2 ++ src/Propellor/Base.hs | 2 ++ src/Propellor/Debug.hs | 36 +++++++++++++++++++++++++++++++ src/Propellor/Message.hs | 49 ++++++++----------------------------------- src/Propellor/Property/Cmd.hs | 2 +- src/Utility/Process.hs | 16 +++++++------- src/Utility/Process/Shim.hs | 8 +++++++ 7 files changed, 66 insertions(+), 49 deletions(-) create mode 100644 src/Propellor/Debug.hs create mode 100644 src/Utility/Process/Shim.hs (limited to 'src/Propellor') diff --git a/propellor.cabal b/propellor.cabal index 7a9d2b5d..63fcaaa5 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -135,6 +135,7 @@ Library Propellor.CmdLine Propellor.Info Propellor.Message + Propellor.Debug Propellor.PrivData Propellor.Engine Propellor.Exception @@ -175,6 +176,7 @@ Library Utility.PartialPrelude Utility.PosixFiles Utility.Process + Utility.Process.Shim Utility.SafeCommand Utility.Scheduled Utility.Table diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index 3c13bb7d..2a0f5cbc 100644 --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -15,6 +15,7 @@ module Propellor.Base ( , module Propellor.Engine , module Propellor.Exception , module Propellor.Message + , module Propellor.Debug , module Propellor.Location , module Propellor.Utilities @@ -39,6 +40,7 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message +import Propellor.Debug import Propellor.Exception import Propellor.Info import Propellor.PropAccum diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs new file mode 100644 index 00000000..ac4a56cc --- /dev/null +++ b/src/Propellor/Debug.hs @@ -0,0 +1,36 @@ +module Propellor.Debug where + +import Control.Applicative +import Control.Monad.IfElse +import System.IO +import System.Directory +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index afe551cf..4be8263e 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -15,24 +15,16 @@ module Propellor.Message ( warningMessage, infoMessage, errorMessage, - debug, - checkDebugMode, - enableDebugMode, processChainOutput, messagesDone, - createProcess, + createProcessConcurrent, ) where import System.Console.ANSI import System.IO import System.Posix.IO -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple import "mtl" Control.Monad.Reader import Control.Applicative -import System.Directory import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -42,13 +34,12 @@ import Data.Char import Data.List import Data.Monoid import qualified Data.ByteString as B +import qualified System.Process as P import Propellor.Types import Utility.PartialPrelude import Utility.Monad -import Utility.Env import Utility.Exception -import qualified Utility.Process as P data MessageHandle = MessageHandle { isConsole :: Bool @@ -131,7 +122,7 @@ dropOutputLock :: IO () dropOutputLock = do lcker <- outputLockedBy <$> getMessageHandle lck <- outputLock <$> getMessageHandle - takeMVar lcker + void $ takeMVar lcker putMVar lck () -- | Only safe to call after takeOutputLock; updates the Locker. @@ -216,27 +207,6 @@ colorLine intensity color msg = do putStrLn "" hFlush stdout -debug :: [String] -> IO () -debug = debugM "propellor" . unwords - -checkDebugMode :: IO () -checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" - where - go (Just "1") = enableDebugMode - go (Just _) = noop - go Nothing = whenM (doesDirectoryExist ".git") $ - whenM (elem "1" . lines <$> getgitconfig) enableDebugMode - getgitconfig = catchDefaultIO "" $ - P.readProcess "git" ["config", "propellor.debug"] - -enableDebugMode :: IO () -enableDebugMode = do - f <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") - updateGlobalLogger rootLoggerName $ - setLevel DEBUG . setHandlers [f] - -- | Reads and displays each line from the Handle, except for the last line -- which is a Result. processChainOutput :: Handle -> IO Result @@ -244,16 +214,13 @@ processChainOutput h = go Nothing where go lastline = do v <- catchMaybeIO (hGetLine h) - debug ["read from chained propellor: ", show v] case v of Nothing -> case lastline of Nothing -> do - debug ["chained propellor output nothing; assuming it failed"] return FailedChange Just l -> case readish l of Just r -> pure r Nothing -> do - debug ["chained propellor output did not end with a Result; assuming it failed"] lockOutput $ do putStrLn l hFlush stdout @@ -287,8 +254,8 @@ messagesDone = lockOutput $ do -- commands, which are based on this. -- -- Also does debug logging of all commands run. -createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcess p +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p | hasoutput (P.std_out p) || hasoutput (P.std_err p) = ifM tryTakeOutputLock ( firstprocess @@ -319,12 +286,12 @@ createProcess p then P.UseHandle toerrh else P.std_err p } - r@(_, _, _, ph) <- P.createProcess p' + r <- P.createProcess p' hClose toouth hClose toerrh buf <- newMVar [] void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromouth stderr buf + void $ async $ outputDrainer fromerrh stderr buf void $ async $ bufferWriter buf return r @@ -349,6 +316,7 @@ outputDrainer fromh toh buf = do -- Wait to lock output, and once we can, display everything -- that's put into buffer, until the end is signaled by Nothing -- for both stdout and stderr. +bufferWriter :: MVar Buffer -> IO () bufferWriter buf = lockOutput (go [stdout, stderr]) where go [] = return () @@ -364,6 +332,7 @@ bufferWriter buf = lockOutput (go [stdout, stderr]) -- The buffer can grow up to 1 mb in size, but after that point, -- it's truncated to avoid propellor using unbounded memory -- when a process outputs a whole lot of stuff. +bufsz :: Int bufsz = 1000000 addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index f2c5b33e..9536f71d 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -27,7 +27,7 @@ import Propellor.Types import Propellor.Property import Utility.SafeCommand import Utility.Env -import Utility.Process (createProcess, CreateProcess) +import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index cc113867..c6699961e 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -41,9 +41,12 @@ module Utility.Process ( devNull, ) where -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, waitForProcess) +import qualified Utility.Process.Shim +import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Misc +import Utility.Exception + import System.Exit import System.IO import System.Log.Logger @@ -58,9 +61,6 @@ import Control.Applicative import Data.Maybe import Prelude -import Utility.Misc -import Utility.Exception - type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle @@ -372,7 +372,7 @@ startInteractiveProcess cmd args environ = do createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p - System.Process.createProcess p + Utility.Process.Shim.createProcess p -- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () @@ -392,6 +392,6 @@ debugProcess p = debugM "Utility.Process" $ unwords -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess h = do - r <- System.Process.waitForProcess h + r <- Utility.Process.Shim.waitForProcess h debugM "Utility.Process" ("process done " ++ show r) return r diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs new file mode 100644 index 00000000..0da93bf7 --- /dev/null +++ b/src/Utility/Process/Shim.hs @@ -0,0 +1,8 @@ +module Utility.Process.Shim (module X, createProcess) where + +import System.Process as X hiding (createProcess) +import Propellor.Message (createProcessConcurrent) +import System.IO + +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess = createProcessConcurrent -- cgit v1.2.3 From 357ffb9fd34ebd36e07dece8e45450dbd2f0e8ec Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 00:12:38 -0400 Subject: concurrency docs --- debian/changelog | 2 +- src/Propellor/Message.hs | 16 ++++++++-------- src/Propellor/Property/Concurrent.hs | 37 +++++++++++++++++++++++++++++++++--- 3 files changed, 43 insertions(+), 12 deletions(-) (limited to 'src/Propellor') diff --git a/debian/changelog b/debian/changelog index 1699b27b..6c154e1a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * combineWith now takes an additional parameter to control how revert actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. - (Note that no command output multiplexing is currently done.) + * execProcess and everything built on it is now concurrent output safe. * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 4be8263e..3792129b 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -238,22 +238,22 @@ messagesDone = lockOutput $ do setTitle "propellor: done" hFlush stdout --- | Wrapper around `System.Process.createProcess` that prevents processes --- that are running concurrently from writing to the stdout/stderr at the --- same time. +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. -- --- The first process run by createProcess is allowed to write to +-- The first process is allowed to write to -- stdout and stderr in the usual way. -- --- However, if a second createProcess runs concurrently with the +-- However, if another process runs concurrently with the -- first, any stdout or stderr that would have been displayed by it is -- instead buffered. The buffered output will be displayed the next time it -- is safe to do so (ie, after the first process exits). -- --- `Propellor.Property.Cmd` has some other useful actions for running --- commands, which are based on this. --- -- Also does debug logging of all commands run. +-- +-- Unless you manually import System.Process, every part of propellor +-- that runs a process uses this. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p | hasoutput (P.std_out p) || hasoutput (P.std_err p) = diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 645a5dfd..74afecc4 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -1,14 +1,38 @@ {-# LANGUAGE FlexibleContexts #-} --- | Note that any output of commands run by --- concurrent properties will be scrambled together. +-- | Propellor properties can be made to run concurrently, using this +-- module. This can speed up propellor, at the expense of using more CPUs +-- and other resources. +-- +-- It's up to you to make sure that properties that you make run concurrently +-- don't implicitly depend on one-another. The worst that can happen +-- though, is that propellor fails to ensure some of the properties, +-- and tells you what went wrong. +-- +-- Another potential problem is that output of concurrent properties could +-- interleave into a scrambled mess. This is mostly prevented; all messages +-- output by propellor are concurrency safe, including `errorMessage`, +-- `infoMessage`, etc. However, if you write a property that directly +-- uses `print` or `putStrLn`, you can still experience this problem. +-- +-- Similarly, when properties run external commands, the command's output +-- can be a problem for concurrency. No need to worry; +-- `Propellor.Property.Cmd.createProcess` is concurrent output safe +-- (it actually uses `Propellor.Message.createProcessConcurrent`), and +-- everything else in propellor that runs external commands is built on top +-- of that. Of course, if you import System.Process and use it in a +-- property, you can bypass that and shoot yourself in the foot. +-- +-- Finally, anything that directly accesses the tty can bypass +-- these protections. That's sometimes done for eg, password prompts. +-- A well-written property should avoid running interactive commands +-- anyway. module Propellor.Property.Concurrent ( concurrently, concurrentList, props, getNumProcessors, - withCapabilities, concurrentSatisfy, ) where @@ -20,6 +44,12 @@ import GHC.Conc (getNumProcessors) import Control.Monad.RWS.Strict -- | Ensures two properties concurrently. +-- +-- > & foo `concurrently` bar +-- +-- To ensure three properties concurrently, just use this combinator twice: +-- +-- > & foo `concurrently` bar `concurrently` baz concurrently :: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2)) => p1 @@ -95,6 +125,7 @@ withCapabilities n a = bracket setup cleanup (const a) return c cleanup = liftIO . setNumCapabilities +-- | Running Propellor actions concurrently. concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result concurrentSatisfy a1 a2 = do h <- ask -- cgit v1.2.3 From af68ec950b2480749182d0d6838e96fd02c2c285 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 10:37:19 -0400 Subject: split out generic ConcurrentOutput module to Utility --- propellor.cabal | 1 + src/Propellor/Message.hs | 204 +----------------------------------- src/Utility/ConcurrentOutput.hs | 224 ++++++++++++++++++++++++++++++++++++++++ src/Utility/Process/Shim.hs | 2 +- 4 files changed, 229 insertions(+), 202 deletions(-) create mode 100644 src/Utility/ConcurrentOutput.hs (limited to 'src/Propellor') diff --git a/propellor.cabal b/propellor.cabal index 63fcaaa5..20e82407 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -161,6 +161,7 @@ Library Propellor.Shim Propellor.Property.Chroot.Util Utility.Applicative + Utility.ConcurrentOutput Utility.Data Utility.DataUnits Utility.Directory diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 3792129b..3b06770c 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PackageImports #-} - -- | This module handles all display of output to the console when -- propellor is ensuring Properties. -- @@ -22,117 +20,34 @@ module Propellor.Message ( import System.Console.ANSI import System.IO -import System.Posix.IO -import "mtl" Control.Monad.Reader +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent -import Control.Concurrent.Async -import Data.Maybe -import Data.Char -import Data.List -import Data.Monoid -import qualified Data.ByteString as B -import qualified System.Process as P import Propellor.Types +import Utility.ConcurrentOutput import Utility.PartialPrelude import Utility.Monad import Utility.Exception data MessageHandle = MessageHandle { isConsole :: Bool - , outputLock :: MVar () -- ^ empty when locked - , outputLockedBy :: MVar Locker } -data Locker - = GeneralLock - | ProcessLock P.ProcessHandle - -- | A shared global variable for the MessageHandle. {-# NOINLINE globalMessageHandle #-} globalMessageHandle :: MVar MessageHandle globalMessageHandle = unsafePerformIO $ newMVar =<< MessageHandle <$> hIsTerminalDevice stdout - <*> newMVar () - <*> newEmptyMVar -- | Gets the global MessageHandle. getMessageHandle :: IO MessageHandle getMessageHandle = readMVar globalMessageHandle --- | Takes a lock while performing an action. Any other threads --- that try to lockOutput at the same time will block. -lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) - --- | Blocks until we have the output lock. -takeOutputLock :: IO () -takeOutputLock = void $ takeOutputLock' True - --- | Tries to take the output lock, without blocking. -tryTakeOutputLock :: IO Bool -tryTakeOutputLock = takeOutputLock' False - -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do - lck <- outputLock <$> getMessageHandle - go =<< tryTakeMVar lck - where - -- lck was full, and we've emptied it, so we hold the lock now. - go (Just ()) = havelock - -- lck is empty, so someone else is holding the lock. - go Nothing = do - lcker <- outputLockedBy <$> getMessageHandle - v' <- tryTakeMVar lcker - case v' of - Just (ProcessLock h) -> - -- if process has exited, lock is stale - ifM (isJust <$> P.getProcessExitCode h) - ( havelock - , if block - then do - void $ P.waitForProcess h - havelock - else do - putMVar lcker (ProcessLock h) - return False - ) - Just GeneralLock -> do - putMVar lcker GeneralLock - whenblock waitlock - Nothing -> whenblock waitlock - - havelock = do - updateOutputLocker GeneralLock - return True - waitlock = do - -- Wait for current lock holder to relinquish - -- it and take the lock. - lck <- outputLock <$> getMessageHandle - takeMVar lck - havelock - whenblock a = if block then a else return False - --- | Only safe to call after taking the output lock. -dropOutputLock :: IO () -dropOutputLock = do - lcker <- outputLockedBy <$> getMessageHandle - lck <- outputLock <$> getMessageHandle - void $ takeMVar lcker - putMVar lck () - --- | Only safe to call after takeOutputLock; updates the Locker. -updateOutputLocker :: Locker -> IO () -updateOutputLocker l = do - lcker <- outputLockedBy <$> getMessageHandle - void $ tryTakeMVar lcker - putMVar lcker l - modifyMVar_ lcker (const $ return l) - -- | Force console output. This can be used when stdout is not directly -- connected to a console, but is eventually going to be displayed at a -- console. @@ -237,116 +152,3 @@ messagesDone = lockOutput $ do whenConsole $ setTitle "propellor: done" hFlush stdout - --- | Wrapper around `System.Process.createProcess` that prevents --- multiple processes that are running concurrently from writing --- to stdout/stderr at the same time. --- --- The first process is allowed to write to --- stdout and stderr in the usual way. --- --- However, if another process runs concurrently with the --- first, any stdout or stderr that would have been displayed by it is --- instead buffered. The buffered output will be displayed the next time it --- is safe to do so (ie, after the first process exits). --- --- Also does debug logging of all commands run. --- --- Unless you manually import System.Process, every part of propellor --- that runs a process uses this. -createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcessConcurrent p - | hasoutput (P.std_out p) || hasoutput (P.std_err p) = - ifM tryTakeOutputLock - ( firstprocess - , concurrentprocess - ) - | otherwise = P.createProcess p - where - hasoutput P.Inherit = True - hasoutput _ = False - - firstprocess = do - r@(_, _, _, h) <- P.createProcess p - `onException` dropOutputLock - updateOutputLocker (ProcessLock h) - -- Output lock is still held as we return; the process - -- is running now, and once it exits the output lock will - -- be stale and can then be taken by something else. - return r - - concurrentprocess = do - (toouth, fromouth) <- pipe - (toerrh, fromerrh) <- pipe - let p' = p - { P.std_out = if hasoutput (P.std_out p) - then P.UseHandle toouth - else P.std_out p - , P.std_err = if hasoutput (P.std_err p) - then P.UseHandle toerrh - else P.std_err p - } - r <- P.createProcess p' - hClose toouth - hClose toerrh - buf <- newMVar [] - void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromerrh stderr buf - void $ async $ bufferWriter buf - return r - - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - -type Buffer = [(Handle, Maybe B.ByteString)] - --- Drain output from the handle, and buffer it in memory. -outputDrainer :: Handle -> Handle -> MVar Buffer -> IO () -outputDrainer fromh toh buf = do - v <- tryIO $ B.hGetSome fromh 1024 - case v of - Right b | not (B.null b) -> do - modifyMVar_ buf (pure . addBuffer (toh, Just b)) - outputDrainer fromh toh buf - _ -> do - modifyMVar_ buf (pure . (++ [(toh, Nothing)])) - hClose fromh - --- Wait to lock output, and once we can, display everything --- that's put into buffer, until the end is signaled by Nothing --- for both stdout and stderr. -bufferWriter :: MVar Buffer -> IO () -bufferWriter buf = lockOutput (go [stdout, stderr]) - where - go [] = return () - go hs = do - l <- takeMVar buf - forM_ l $ \(h, mb) -> do - maybe noop (B.hPut h) mb - hFlush h - let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs - putMVar buf [] - go hs' - --- The buffer can grow up to 1 mb in size, but after that point, --- it's truncated to avoid propellor using unbounded memory --- when a process outputs a whole lot of stuff. -bufsz :: Int -bufsz = 1000000 - -addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer -addBuffer v@(_, Nothing) buf = buf ++ [v] -addBuffer (toh, Just b) buf = (toh, Just b') : other - where - (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf - b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b - --- Truncate a buffer by removing lines from the front until it's --- small enough. -truncateBuffer :: B.ByteString -> B.ByteString -truncateBuffer b - | B.length b <= bufsz = b - | otherwise = truncateBuffer $ snd $ B.breakByte nl b - where - nl = fromIntegral (ord '\n') diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs new file mode 100644 index 00000000..cf1d166e --- /dev/null +++ b/src/Utility/ConcurrentOutput.hs @@ -0,0 +1,224 @@ +-- | Concurrent output handling. +-- +-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. + +module Utility.ConcurrentOutput ( + lockOutput, + createProcessConcurrent, +) where + +import System.IO +import System.Posix.IO +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Applicative +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import Control.Concurrent.Async +import Data.Maybe +import Data.Char +import Data.List +import Data.Monoid +import qualified Data.ByteString as B +import qualified System.Process as P + +import Utility.Monad +import Utility.Exception + +data OutputHandle = OutputHandle + { outputLock :: MVar () -- ^ empty when locked + , outputLockedBy :: MVar Locker + } + +data Locker + = GeneralLock + | ProcessLock P.ProcessHandle + +-- | A shared global variable for the OutputHandle. +{-# NOINLINE globalOutputHandle #-} +globalOutputHandle :: MVar OutputHandle +globalOutputHandle = unsafePerformIO $ + newMVar =<< OutputHandle + <$> newMVar () + <*> newEmptyMVar + +-- | Gets the global OutputHandle. +getOutputHandle :: IO OutputHandle +getOutputHandle = readMVar globalOutputHandle + +-- | Holds a lock while performing an action. Any other threads +-- that try to lockOutput at the same time will block. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + lck <- outputLock <$> getOutputHandle + go =<< tryTakeMVar lck + where + -- lck was full, and we've emptied it, so we hold the lock now. + go (Just ()) = havelock + -- lck is empty, so someone else is holding the lock. + go Nothing = do + lcker <- outputLockedBy <$> getOutputHandle + v' <- tryTakeMVar lcker + case v' of + Just (ProcessLock h) -> + -- if process has exited, lock is stale + ifM (isJust <$> P.getProcessExitCode h) + ( havelock + , if block + then do + void $ P.waitForProcess h + havelock + else do + putMVar lcker (ProcessLock h) + return False + ) + Just GeneralLock -> do + putMVar lcker GeneralLock + whenblock waitlock + Nothing -> whenblock waitlock + + havelock = do + updateOutputLocker GeneralLock + return True + waitlock = do + -- Wait for current lock holder to relinquish + -- it and take the lock. + lck <- outputLock <$> getOutputHandle + takeMVar lck + havelock + whenblock a = if block then a else return False + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = do + lcker <- outputLockedBy <$> getOutputHandle + lck <- outputLock <$> getOutputHandle + void $ takeMVar lcker + putMVar lck () + +-- | Only safe to call after takeOutputLock; updates the Locker. +updateOutputLocker :: Locker -> IO () +updateOutputLocker l = do + lcker <- outputLockedBy <$> getOutputHandle + void $ tryTakeMVar lcker + putMVar lcker l + modifyMVar_ lcker (const $ return l) + +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. +-- +-- The first process is allowed to write to stdout and stderr in the usual way. +-- +-- However, if another process runs concurrently with the +-- first, any stdout or stderr that would have been displayed by it is +-- instead buffered. The buffered output will be displayed the next time it +-- is safe to do so (ie, after the first process exits). +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p + | hasoutput (P.std_out p) || hasoutput (P.std_err p) = + ifM tryTakeOutputLock + ( firstprocess + , concurrentprocess + ) + | otherwise = P.createProcess p + where + hasoutput P.Inherit = True + hasoutput _ = False + + firstprocess = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + updateOutputLocker (ProcessLock h) + -- Output lock is still held as we return; the process + -- is running now, and once it exits the output lock will + -- be stale and can then be taken by something else. + return r + + concurrentprocess = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = if hasoutput (P.std_out p) + then P.UseHandle toouth + else P.std_out p + , P.std_err = if hasoutput (P.std_err p) + then P.UseHandle toerrh + else P.std_err p + } + r <- P.createProcess p' + hClose toouth + hClose toerrh + buf <- newMVar [] + void $ async $ outputDrainer fromouth stdout buf + void $ async $ outputDrainer fromerrh stderr buf + void $ async $ bufferWriter buf + return r + + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + +type Buffer = [(Handle, Maybe B.ByteString)] + +-- Drain output from the handle, and buffer it in memory. +outputDrainer :: Handle -> Handle -> MVar Buffer -> IO () +outputDrainer fromh toh buf = do + v <- tryIO $ B.hGetSome fromh 1024 + case v of + Right b | not (B.null b) -> do + modifyMVar_ buf (pure . addBuffer (toh, Just b)) + outputDrainer fromh toh buf + _ -> do + modifyMVar_ buf (pure . (++ [(toh, Nothing)])) + hClose fromh + +-- Wait to lock output, and once we can, display everything +-- that's put into buffer, until the end is signaled by Nothing +-- for both stdout and stderr. +bufferWriter :: MVar Buffer -> IO () +bufferWriter buf = lockOutput (go [stdout, stderr]) + where + go [] = return () + go hs = do + l <- takeMVar buf + forM_ l $ \(h, mb) -> do + maybe noop (B.hPut h) mb + hFlush h + let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs + putMVar buf [] + go hs' + +-- The buffer can grow up to 1 mb in size, but after that point, +-- it's truncated to avoid propellor using unbounded memory +-- when a process outputs a whole lot of stuff. +bufsz :: Int +bufsz = 1000000 + +addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer +addBuffer v@(_, Nothing) buf = buf ++ [v] +addBuffer (toh, Just b) buf = (toh, Just b') : other + where + (this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf + b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b + +-- Truncate a buffer by removing lines from the front until it's +-- small enough. +truncateBuffer :: B.ByteString -> B.ByteString +truncateBuffer b + | B.length b <= bufsz = b + | otherwise = truncateBuffer $ snd $ B.breakByte nl b + where + nl = fromIntegral (ord '\n') diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs index 0da93bf7..202b7c32 100644 --- a/src/Utility/Process/Shim.hs +++ b/src/Utility/Process/Shim.hs @@ -1,7 +1,7 @@ module Utility.Process.Shim (module X, createProcess) where import System.Process as X hiding (createProcess) -import Propellor.Message (createProcessConcurrent) +import Utility.ConcurrentOutput (createProcessConcurrent) import System.IO createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -- cgit v1.2.3 From 21a74a3ffea3d48195d76486a56031b317fa23fa Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 11:44:05 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 5 ++++- src/Utility/ConcurrentOutput.hs | 28 ++++++++++------------------ 2 files changed, 14 insertions(+), 19 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 0c457705..36859fb7 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -206,7 +206,10 @@ updateServer target relay hst connect haveprecompiled getprivdata = sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn toh =<< getprivdata + print "START GET PRIVDATA" + pd <- getprivdata + print "GOT PRIVDATA" + sendPrivData hn toh pd loop (Just NeedGitClone) -> do hClose toh diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 35904cb7..8a4bdcf2 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -130,23 +130,19 @@ updateOutputLocker l = do -- as the output lock becomes free. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p - | hasoutput (P.std_out p) || hasoutput (P.std_err p) = + | willoutput (P.std_out p) || willoutput (P.std_err p) = ifM tryTakeOutputLock - ( do - print ("FIRST", pc) - firstprocess - , do - print ("CONCURRENT", pc) - concurrentprocess + ( firstprocess + , concurrentprocess ) | otherwise = P.createProcess p where - hasoutput P.Inherit = True - hasoutput _ = False + willoutput P.Inherit = True + willoutput _ = False - pc = case P.cmdspec p of - P.ShellCommand s -> s - P.RawCommand c ps -> unwords (c:ps) + rediroutput str h + | willoutput str = P.UseHandle h + | otherwise = str firstprocess = do r@(_, _, _, h) <- P.createProcess p @@ -161,12 +157,8 @@ createProcessConcurrent p (toouth, fromouth) <- pipe (toerrh, fromerrh) <- pipe let p' = p - { P.std_out = if hasoutput (P.std_out p) - then P.UseHandle toouth - else P.std_out p - , P.std_err = if hasoutput (P.std_err p) - then P.UseHandle toerrh - else P.std_err p + { P.std_out = rediroutput (P.std_out p) toouth + , P.std_err = rediroutput (P.std_err p) toerrh } r <- P.createProcess p' hClose toouth -- cgit v1.2.3 From 92cc0610586f0875286a945ea21477f0fc852f08 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 11:46:03 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 36859fb7..49d80460 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -15,6 +15,7 @@ import System.Posix.Directory import Control.Concurrent.Async import qualified Data.ByteString as B import qualified Data.Set as S +import qualified Data.Map as M import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr) import Propellor.Base @@ -208,7 +209,7 @@ updateServer target relay hst connect haveprecompiled getprivdata = (Just NeedPrivData) -> do print "START GET PRIVDATA" pd <- getprivdata - print "GOT PRIVDATA" + print ("GOT PRIVDATA", M.size pd) sendPrivData hn toh pd loop (Just NeedGitClone) -> do -- cgit v1.2.3 From 1f0e7001aafb91e7ed168505db1aa62a8b070234 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 11:47:39 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 49d80460..ef3dc2d1 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -208,8 +208,10 @@ updateServer target relay hst connect haveprecompiled getprivdata = loop (Just NeedPrivData) -> do print "START GET PRIVDATA" + hFlush stdout pd <- getprivdata print ("GOT PRIVDATA", M.size pd) + hFlush stdout sendPrivData hn toh pd loop (Just NeedGitClone) -> do -- cgit v1.2.3 From f935d1d667f78ba7d34e853346ab0a99b2c4ec14 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 11:49:12 -0400 Subject: remove debug Found problem.. actionMessage is blocking. --- src/Propellor/Spin.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index ef3dc2d1..8a40fc87 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -15,7 +15,6 @@ import System.Posix.Directory import Control.Concurrent.Async import qualified Data.ByteString as B import qualified Data.Set as S -import qualified Data.Map as M import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr) import Propellor.Base @@ -207,12 +206,7 @@ updateServer target relay hst connect haveprecompiled getprivdata = sendRepoUrl toh loop (Just NeedPrivData) -> do - print "START GET PRIVDATA" - hFlush stdout - pd <- getprivdata - print ("GOT PRIVDATA", M.size pd) - hFlush stdout - sendPrivData hn toh pd + sendPrivData hn toh pd =<< getprivdata loop (Just NeedGitClone) -> do hClose toh -- cgit v1.2.3 From 7a83dab6e977f61b3348aaa9f70bd2a288b4b631 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:19:49 -0400 Subject: use outputConcurrent interface This interface will fix the current deadlock when a process is running and the thread that ran it wants to output to the console. The locking and buffering is not implemented yet. --- src/Propellor/Message.hs | 91 +++++++++++++++++++---------------------- src/Propellor/Spin.hs | 2 +- src/Utility/ConcurrentOutput.hs | 21 ++++++++-- 3 files changed, 61 insertions(+), 53 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 3b06770c..6d541b9a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -20,10 +20,8 @@ module Propellor.Message ( import System.Console.ANSI import System.IO -import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative -import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -55,10 +53,11 @@ forceConsole :: IO () forceConsole = modifyMVar_ globalMessageHandle $ \mh -> pure (mh { isConsole = True }) --- | Only performs the action when at the console, or when console --- output has been forced. -whenConsole :: IO () -> IO () -whenConsole a = whenM (isConsole <$> getMessageHandle) a +whenConsole :: String -> IO String +whenConsole s = ifM (isConsole <$> getMessageHandle) + ( pure s + , pure "" + ) -- | Shows a message while performing an action, with a colored status -- display. @@ -72,55 +71,54 @@ actionMessageOn = actionMessage' . Just actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - liftIO $ whenConsole $ lockOutput $ do - setTitle $ "propellor: " ++ desc - hFlush stdout + liftIO $ outputConcurrent + =<< whenConsole (setTitleCode $ "propellor: " ++ desc) r <- a - liftIO $ lockOutput $ do - whenConsole $ - setTitle "propellor: running" - showhn mhn - putStr $ desc ++ " ... " - let (msg, intensity, color) = getActionResult r - colorLine intensity color msg - hFlush stdout + liftIO $ outputConcurrent . concat =<< sequence + [ whenConsole $ + setTitleCode "propellor: running" + , showhn mhn + , pure $ desc ++ " ... " + , let (msg, intensity, color) = getActionResult r + in colorLine intensity color msg + ] return r where - showhn Nothing = return () - showhn (Just hn) = do - whenConsole $ - setSGR [SetColor Foreground Dull Cyan] - putStr (hn ++ " ") - whenConsole $ - setSGR [] + showhn Nothing = return "" + showhn (Just hn) = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground Dull Cyan] + , pure (hn ++ " ") + , whenConsole $ + setSGRCode [] + ] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ lockOutput $ - colorLine Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) infoMessage :: MonadIO m => [String] -> m () -infoMessage ls = liftIO $ lockOutput $ - mapM_ putStrLn ls +infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls errorMessage :: MonadIO m => String -> m a -errorMessage s = liftIO $ lockOutput $ do - colorLine Vivid Red $ "** error: " ++ s +errorMessage s = liftIO $ do + outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) error "Cannot continue!" -colorLine :: ColorIntensity -> Color -> String -> IO () -colorLine intensity color msg = do - whenConsole $ - setSGR [SetColor Foreground intensity color] - putStr msg - whenConsole $ - setSGR [] +colorLine :: ColorIntensity -> Color -> String -> IO String +colorLine intensity color msg = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground intensity color] + , pure msg + , whenConsole $ + setSGRCode [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. - putStrLn "" - hFlush stdout + , pure "\n" + ] -- | Reads and displays each line from the Handle, except for the last line -- which is a Result. @@ -136,19 +134,14 @@ processChainOutput h = go Nothing Just l -> case readish l of Just r -> pure r Nothing -> do - lockOutput $ do - putStrLn l - hFlush stdout + outputConcurrent l return FailedChange Just s -> do - lockOutput $ do - maybe noop (\l -> unless (null l) (putStrLn l)) lastline - hFlush stdout + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline go (Just s) -- | Called when all messages about properties have been printed. messagesDone :: IO () -messagesDone = lockOutput $ do - whenConsole $ - setTitle "propellor: done" - hFlush stdout +messagesDone = outputConcurrent + =<< whenConsole (setTitleCode "propellor: done") diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 8a40fc87..0c457705 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -206,7 +206,7 @@ updateServer target relay hst connect haveprecompiled getprivdata = sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn toh pd =<< getprivdata + sendPrivData hn toh =<< getprivdata loop (Just NeedGitClone) -> do hClose toh diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 8a4bdcf2..0e9a59de 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,7 +1,7 @@ -- | Concurrent output handling. module Utility.ConcurrentOutput ( - lockOutput, + outputConcurrent, createProcessConcurrent, ) where @@ -113,6 +113,20 @@ updateOutputLocker l = do putMVar lcker l modifyMVar_ lcker (const $ return l) +-- | Displays a string to stdout, and flush output so it's displayed. +-- +-- Uses locking to ensure that the whole string is output atomically +-- even when other threads are concurrently generating output. +-- +-- When something else is writing to the console at the same time, this does +-- not block. It buffers the string, so it will be displayed once the other +-- writer is done. +outputConcurrent :: String -> IO () +outputConcurrent s = do + putStr s + hFlush stdout + -- TODO + -- | Wrapper around `System.Process.createProcess` that prevents -- multiple processes that are running concurrently from writing -- to stdout/stderr at the same time. @@ -124,8 +138,9 @@ updateOutputLocker l = do -- A process is allowed to write to stdout and stderr in the usual -- way, assuming it can successfully take the output lock. -- --- When the output lock is held (by another process or other caller of --- `lockOutput`), the process is instead run with its stdout and stderr +-- When the output lock is held (by another concurrent process, +-- or because `outputConcurrent` is being called at the same time), +-- the process is instead run with its stdout and stderr -- redirected to a buffer. The buffered output will be displayed as soon -- as the output lock becomes free. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -- cgit v1.2.3 From 68dbfe1b08c9cf1d976ac84ea53817c54fcd3479 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 12:41:15 -0400 Subject: need withConcurrentOutput to flush any buffered concurrent output --- src/Propellor/CmdLine.hs | 2 +- src/Propellor/Message.hs | 1 + src/Utility/ConcurrentOutput.hs | 13 +++++++++++++ src/wrapper.hs | 2 +- 4 files changed, 16 insertions(+), 2 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 9f798166..4bca3986 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -89,7 +89,7 @@ processCmdLine = go =<< getArgs -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () -defaultMain hostlist = do +defaultMain hostlist = withConcurrentOutput $ do Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 6d541b9a..7439c362 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -16,6 +16,7 @@ module Propellor.Message ( processChainOutput, messagesDone, createProcessConcurrent, + withConcurrentOutput, ) where import System.Console.ANSI diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 1ca92d90..c6550b84 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,6 +1,7 @@ -- | Concurrent output handling. module Utility.ConcurrentOutput ( + withConcurrentOutput, outputConcurrent, createProcessConcurrent, ) where @@ -113,6 +114,18 @@ updateOutputLocker l = do putMVar lcker l modifyMVar_ lcker (const $ return l) +-- | Use this around any IO actions that use `outputConcurrent` +-- or `createProcessConcurrent` +-- +-- This is necessary to ensure that buffered concurrent output actually +-- gets displayed before the program exits. +withConcurrentOutput :: IO a -> IO a +withConcurrentOutput a = a `finally` drain + where + -- Just taking the output lock is enough to ensure that anything + -- that was buffering output has had a chance to flush its buffer. + drain = lockOutput (return ()) + -- | Displays a string to stdout, and flush output so it's displayed. -- -- Uses locking to ensure that the whole string is output atomically diff --git a/src/wrapper.hs b/src/wrapper.hs index e367fe69..0cfe319d 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -50,7 +50,7 @@ netrepo :: String netrepo = "https://github.com/joeyh/propellor.git" main :: IO () -main = do +main = withConcurrentOutput $ do args <- getArgs home <- myHomeDir let propellordir = home ".propellor" -- cgit v1.2.3 From 111ea88d4d7c54e9ab7950962ad22528d54dd959 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 14:46:17 -0400 Subject: fix bad MVar use, use STM I had 2 MVars both involved in the same lock, and it seemed intractable to avoid deadlocks with them. STM makes it easy. At this point, the concurrent process stuff seems to work pretty well, but I'm not 100% sure it's not got some bugs. --- debian/changelog | 1 + debian/control | 2 + propellor.cabal | 6 +- src/Propellor/Bootstrap.hs | 3 +- src/Utility/ConcurrentOutput.hs | 173 ++++++++++++++++++++++------------------ 5 files changed, 104 insertions(+), 81 deletions(-) (limited to 'src/Propellor') diff --git a/debian/changelog b/debian/changelog index 6c154e1a..f3522b7c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -19,6 +19,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium actions are combined (API change). * Added Propellor.Property.Concurrent for concurrent properties. * execProcess and everything built on it is now concurrent output safe. + * Propellor now depends on stm. * Add File.isCopyOf. Thanks, Per Olofsson. -- Joey Hess Sat, 24 Oct 2015 15:16:45 -0400 diff --git a/debian/control b/debian/control index 7f42c916..2956fdaa 100644 --- a/debian/control +++ b/debian/control @@ -17,6 +17,7 @@ Build-Depends: libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-stm-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -39,6 +40,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-stm-dev, git, make, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal index 20e82407..da43775f 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -39,7 +39,7 @@ Executable propellor Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6) + exceptions (>= 0.6), stm if (! os(windows)) Build-Depends: unix @@ -51,7 +51,7 @@ Executable propellor-config Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm if (! os(windows)) Build-Depends: unix @@ -62,7 +62,7 @@ Library Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 6a5d5acb..2318b910 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -65,7 +65,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " aptinstall p = "apt-get --no-upgrade --no-install-recommends -y install " ++ p - -- This is the same build deps listed in debian/control. + -- This is the same deps listed in debian/control. debdeps = [ "gnupg" , "ghc" @@ -81,6 +81,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-mtl-dev" , "libghc-transformers-dev" , "libghc-exceptions-dev" + , "libghc-stm-dev" , "make" ] diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index c6550b84..5535066f 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + -- | Concurrent output handling. module Utility.ConcurrentOutput ( @@ -14,6 +16,7 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent +import Control.Concurrent.STM import Control.Concurrent.Async import Data.Maybe import Data.List @@ -25,21 +28,23 @@ import Utility.Monad import Utility.Exception data OutputHandle = OutputHandle - { outputLock :: MVar () -- ^ empty when locked - , outputLockedBy :: MVar Locker + { outputLock :: TMVar (Maybe Locker) } data Locker = GeneralLock - | ProcessLock P.ProcessHandle + | ProcessLock P.ProcessHandle String + +instance Show Locker where + show GeneralLock = "GeneralLock" + show (ProcessLock _ cmd) = "ProcessLock " ++ cmd -- | A shared global variable for the OutputHandle. {-# NOINLINE globalOutputHandle #-} globalOutputHandle :: MVar OutputHandle globalOutputHandle = unsafePerformIO $ newMVar =<< OutputHandle - <$> newMVar () - <*> newEmptyMVar + <$> newTMVarIO Nothing -- | Gets the global OutputHandle. getOutputHandle :: IO OutputHandle @@ -58,61 +63,69 @@ takeOutputLock = void $ takeOutputLock' True tryTakeOutputLock :: IO Bool tryTakeOutputLock = takeOutputLock' False -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do +withLock :: (TMVar (Maybe Locker) -> STM a) -> IO a +withLock a = do lck <- outputLock <$> getOutputHandle - go =<< tryTakeMVar lck + atomically (a lck) + +-- The lock TMVar is kept full normally, even if only with Nothing, +-- so if we take it here, that blocks anyone else from trying +-- to take the lock while we are checking it. +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = go =<< withLock tryTakeTMVar where - -- lck was full, and we've emptied it, so we hold the lock now. - go (Just ()) = havelock - -- lck is empty, so someone else is holding the lock. - go Nothing = do - lcker <- outputLockedBy <$> getOutputHandle - v' <- tryTakeMVar lcker - case v' of - Just (ProcessLock h) -> - -- if process has exited, lock is stale - ifM (isJust <$> P.getProcessExitCode h) - ( havelock - , if block - then do - void $ P.waitForProcess h - havelock - else do - putMVar lcker (ProcessLock h) - return False - ) - Just GeneralLock -> do - putMVar lcker GeneralLock - whenblock waitlock - Nothing -> whenblock waitlock + go Nothing = whenblock waitlock + -- Something has the lock. It may be stale, so check it. + -- We must always be sure to fill the TMVar back with Just or Nothing. + go (Just orig) = case orig of + Nothing -> havelock + (Just (ProcessLock h _)) -> + -- when process has exited, lock is stale + ifM (isJust <$> P.getProcessExitCode h) + ( havelock + , if block + then do + hPutStr stderr "WAITFORPROCESS in lock" + hFlush stderr + void $ P.waitForProcess h + hPutStr stderr "WAITFORPROCESS in lock done" + hFlush stderr + havelock + else do + withLock (`putTMVar` orig) + return False + ) + (Just GeneralLock) -> do + withLock (`putTMVar` orig) + whenblock waitlock havelock = do - updateOutputLocker GeneralLock + withLock (`putTMVar` Just GeneralLock) return True - waitlock = do - -- Wait for current lock holder to relinquish - -- it and take the lock. - lck <- outputLock <$> getOutputHandle - takeMVar lck - havelock + + -- Wait for current lock holder (if any) to relinquish + -- it and take the lock for ourselves. + waitlock = withLock $ \l -> do + v <- tryTakeTMVar l + case v of + Just (Just _) -> retry + _ -> do + putTMVar l (Just GeneralLock) + return True + whenblock a = if block then a else return False -- | Only safe to call after taking the output lock. dropOutputLock :: IO () -dropOutputLock = do - lcker <- outputLockedBy <$> getOutputHandle - lck <- outputLock <$> getOutputHandle - void $ takeMVar lcker - putMVar lck () +dropOutputLock = withLock $ \l -> do + void $ takeTMVar l + putTMVar l Nothing -- | Only safe to call after takeOutputLock; updates the Locker. updateOutputLocker :: Locker -> IO () -updateOutputLocker l = do - lcker <- outputLockedBy <$> getOutputHandle - void $ tryTakeMVar lcker - putMVar lcker l - modifyMVar_ lcker (const $ return l) +updateOutputLocker locker = withLock $ \l -> do + void $ takeTMVar l + putTMVar l (Just locker) -- | Use this around any IO actions that use `outputConcurrent` -- or `createProcessConcurrent` @@ -124,7 +137,7 @@ withConcurrentOutput a = a `finally` drain where -- Just taking the output lock is enough to ensure that anything -- that was buffering output has had a chance to flush its buffer. - drain = lockOutput (return ()) + drain = lockOutput noop -- | Displays a string to stdout, and flush output so it's displayed. -- @@ -158,28 +171,25 @@ outputConcurrent s = do -- as the output lock becomes free. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p - | willoutput (P.std_out p) || willoutput (P.std_err p) = + | willOutput (P.std_out p) || willOutput (P.std_err p) = ifM tryTakeOutputLock - ( do - hPutStrLn stderr "IS NOT CONCURRENT" - firstprocess - , do - hPutStrLn stderr "IS CONCURRENT" - concurrentprocess + ( firstprocess + , concurrentprocess ) | otherwise = P.createProcess p where - willoutput P.Inherit = True - willoutput _ = False + rediroutput ss h + | willOutput ss = P.UseHandle h + | otherwise = ss - rediroutput str h - | willoutput str = P.UseHandle h - | otherwise = str + cmd = case P.cmdspec p of + P.ShellCommand s -> s + P.RawCommand c ps -> unwords (c:ps) firstprocess = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock - updateOutputLocker (ProcessLock h) + updateOutputLocker (ProcessLock h cmd) -- Output lock is still held as we return; the process -- is running now, and once it exits the output lock will -- be stale and can then be taken by something else. @@ -196,8 +206,8 @@ createProcessConcurrent p hClose toouth hClose toerrh buf <- newMVar [] - void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromerrh stderr buf + void $ async $ outputDrainer (P.std_out p) fromouth stdout buf + void $ async $ outputDrainer (P.std_err p) fromerrh stderr buf void $ async $ bufferWriter buf return r @@ -205,6 +215,10 @@ createProcessConcurrent p (from, to) <- createPipe (,) <$> fdToHandle to <*> fdToHandle from +willOutput :: P.StdStream -> Bool +willOutput P.Inherit = True +willOutput _ = False + type Buffer = [(Handle, BufferedActivity)] data BufferedActivity @@ -213,17 +227,22 @@ data BufferedActivity | InTempFile FilePath deriving (Eq) --- Drain output from the handle, and buffer it in memory. -outputDrainer :: Handle -> Handle -> MVar Buffer -> IO () -outputDrainer fromh toh buf = do - v <- tryIO $ B.hGetSome fromh 1024 - case v of - Right b | not (B.null b) -> do - modifyMVar_ buf $ addBuffer (toh, Output b) - outputDrainer fromh toh buf - _ -> do - modifyMVar_ buf $ pure . (++ [(toh, ReachedEnd)]) - hClose fromh +-- Drain output from the handle, and buffer it. +outputDrainer :: P.StdStream -> Handle -> Handle -> MVar Buffer -> IO () +outputDrainer ss fromh toh buf + | willOutput ss = go + | otherwise = atend + where + go = do + v <- tryIO $ B.hGetSome fromh 1024 + case v of + Right b | not (B.null b) -> do + modifyMVar_ buf $ addBuffer (toh, Output b) + go + _ -> atend + atend = do + modifyMVar_ buf $ pure . (++ [(toh, ReachedEnd)]) + hClose fromh -- Wait to lock output, and once we can, display everything -- that's put into buffer, until the end is signaled by Nothing @@ -262,8 +281,8 @@ addBuffer (toh, Output b) buf hClose h return ((toh, InTempFile tmp) : other) where - b' = B.concat (mapMaybe getOutput this) <> b - (this, other) = partition same buf + !b' = B.concat (mapMaybe getOutput this) <> b + !(this, other) = partition same buf same v = fst v == toh && case snd v of Output _ -> True _ -> False -- cgit v1.2.3 From 86a115aaa0c216e4c46e57a324b58177c8b78435 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 20:10:11 -0400 Subject: have to flush concurrent output before printing result when chaining --- src/Propellor/Message.hs | 2 +- src/Propellor/Property/Chroot.hs | 1 + src/Propellor/Property/Docker.hs | 2 ++ src/Utility/ConcurrentOutput.hs | 30 +++++++++++++++++------------- 4 files changed, 21 insertions(+), 14 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 7439c362..7df5104a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -135,7 +135,7 @@ processChainOutput h = go Nothing Just l -> case readish l of Just r -> pure r Nothing -> do - outputConcurrent l + outputConcurrent (l ++ "\n") return FailedChange Just s -> do outputConcurrent $ diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 8b923aab..e72d1bd9 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -213,6 +213,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = then [Systemd.installed] else map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 5f41209a..9082460f 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -540,6 +540,7 @@ init s = case toContainerId s of warningMessage "Boot provision failed!" void $ async $ job reapzombies job $ do + flushConcurrentOutput void $ tryIO $ ifM (inPath "bash") ( boolSystem "bash" [Param "-l"] , boolSystem "/bin/sh" [] @@ -583,6 +584,7 @@ chain hostlist hn s = case toContainerId s of r <- runPropellor h $ ensureProperties $ map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index db0bae0a..3f28068a 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -5,6 +5,7 @@ module Utility.ConcurrentOutput ( withConcurrentOutput, + flushConcurrentOutput, outputConcurrent, createProcessConcurrent, waitForProcessConcurrent, @@ -105,19 +106,22 @@ dropOutputLock = withLock $ void . takeTMVar -- This is necessary to ensure that buffered concurrent output actually -- gets displayed before the program exits. withConcurrentOutput :: IO a -> IO a -withConcurrentOutput a = a `finally` drain - where - -- Wait for all outputThreads to finish. Then, take the output lock - -- to ensure that nothing is currently generating output, and flush - -- any buffered output. - drain = do - v <- outputThreads <$> getOutputHandle - atomically $ do - r <- takeTMVar v - if r == S.empty - then return () - else retry - lockOutput $ return () +withConcurrentOutput a = a `finally` flushConcurrentOutput + +-- | Blocks until any processes started by `createProcessConcurrent` have +-- finished, and any buffered output is displayed. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + -- Wait for all outputThreads to finish. + v <- outputThreads <$> getOutputHandle + atomically $ do + r <- takeTMVar v + if r == S.empty + then return () + else retry + -- Take output lock to ensure that nothing else is currently + -- generating output, and flush any buffered output. + lockOutput $ return () -- | Displays a string to stdout, and flush output so it's displayed. -- -- cgit v1.2.3 From 7f1e82da152b8eb085e91cddc369831fbfdb7a37 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 20:12:06 -0400 Subject: propellor spin --- src/Propellor/Property/Chroot.hs | 1 + src/Propellor/Property/Docker.hs | 1 + 2 files changed, 2 insertions(+) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index e72d1bd9..0c00e8f4 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -27,6 +27,7 @@ import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount +import Utility.ConcurrentOutput import qualified Data.Map as M import Data.List.Utils diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 9082460f..f2dbaaf5 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -56,6 +56,7 @@ import qualified Propellor.Property.Cmd as Cmd import qualified Propellor.Shim as Shim import Utility.Path import Utility.ThreadScheduler +import Utility.ConcurrentOutput import Control.Concurrent.Async hiding (link) import System.Posix.Directory -- cgit v1.2.3 From dba2e73aa7daede014969d6c4c159e86871d6b01 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 28 Oct 2015 20:20:53 -0400 Subject: propellor spin --- src/Propellor/Spin.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src/Propellor') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 0c457705..478d1517 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -29,6 +29,7 @@ import Propellor.Types.Info import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand +import Utility.ConcurrentOutput commitSpin :: IO () commitSpin = do @@ -63,6 +64,7 @@ spin' mprivdata relay target hst = do getprivdata -- And now we can run it. + flushConcurrentOutput unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ error "remote propellor failed" where -- cgit v1.2.3 From 39fa051833de3178639974fa4fc7c803c5918f0e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 29 Oct 2015 00:38:53 -0400 Subject: generalize what can be output This adds a dependency on Text, but I don't mind propellor depending on it and am somewhat surprised it doesn't already. Using Text also lets this use encodeUtf8 instead of the nasty hack it was using to go from String -> ByteString. --- debian/changelog | 2 +- debian/control | 2 ++ propellor.cabal | 6 +++--- src/Propellor/Bootstrap.hs | 1 + src/Utility/ConcurrentOutput.hs | 35 +++++++++++++++++++++++++---------- 5 files changed, 32 insertions(+), 14 deletions(-) (limited to 'src/Propellor') diff --git a/debian/changelog b/debian/changelog index c5538c7f..6f75bce9 100644 --- a/debian/changelog +++ b/debian/changelog @@ -20,7 +20,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * Added Propellor.Property.Concurrent for concurrent properties. * Made the execProcess exported by propellor, and everything built on it, avoid scrambled output when run concurrently. - * Propellor now depends on STM. + * Propellor now depends on STM and text. * The cabal file now builds propellor with -O. While -O0 makes ghc take less memory while building propellor, it can lead to bad memory usage at runtime due to eg, disabled stream fusion. diff --git a/debian/control b/debian/control index 2956fdaa..97fb3e6d 100644 --- a/debian/control +++ b/debian/control @@ -18,6 +18,7 @@ Build-Depends: libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, + libghc-text-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -41,6 +42,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, + libghc-text-dev, git, make, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal index a07109a7..6e871d6b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -39,7 +39,7 @@ Executable propellor Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6), stm + exceptions (>= 0.6), stm, text if (! os(windows)) Build-Depends: unix @@ -51,7 +51,7 @@ Executable propellor-config Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm + exceptions, stm, text if (! os(windows)) Build-Depends: unix @@ -62,7 +62,7 @@ Library Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm + exceptions, stm, text if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 2318b910..21772b34 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -82,6 +82,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-transformers-dev" , "libghc-exceptions-dev" , "libghc-stm-dev" + , "libghc-text-dev" , "make" ] diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 94cd4202..c24744a3 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -- | @@ -20,6 +20,7 @@ module Utility.ConcurrentOutput ( withConcurrentOutput, flushConcurrentOutput, + Outputable(..), outputConcurrent, createProcessConcurrent, waitForProcessConcurrent, @@ -40,13 +41,14 @@ import Control.Concurrent.Async import Data.Maybe import Data.List import Data.Monoid -import qualified Data.ByteString as B import qualified System.Process as P import qualified Data.Set as S +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Utility.Monad import Utility.Exception -import Utility.FileSystemEncoding data OutputHandle = OutputHandle { outputLock :: TMVar Lock @@ -137,27 +139,40 @@ flushConcurrentOutput = do -- generating output, and flush any buffered output. lockOutput $ return () --- | Displays a string to stdout, and flush output so it's displayed. +-- | Values that can be output. +class Outputable v where + toOutput :: v -> B.ByteString + +instance Outputable B.ByteString where + toOutput = id + +instance Outputable T.Text where + toOutput = encodeUtf8 + +instance Outputable String where + toOutput = toOutput . T.pack + +-- | Displays a value to stdout, and flush output so it's displayed. -- --- Uses locking to ensure that the whole string is output atomically +-- Uses locking to ensure that the whole output occurs atomically -- even when other threads are concurrently generating output. -- -- When something else is writing to the console at the same time, this does --- not block. It buffers the string, so it will be displayed once the other +-- not block. It buffers the value, so it will be displayed once the other -- writer is done. -outputConcurrent :: String -> IO () -outputConcurrent s = bracket setup cleanup go +outputConcurrent :: Outputable v => v -> IO () +outputConcurrent v = bracket setup cleanup go where setup = tryTakeOutputLock cleanup False = return () cleanup True = dropOutputLock go True = do - putStr s + B.hPut stdout (toOutput v) hFlush stdout go False = do bv <- outputBuffer <$> getOutputHandle oldbuf <- atomically $ takeTMVar bv - newbuf <- addBuffer (Output (B.pack (decodeW8NUL s))) oldbuf + newbuf <- addBuffer (Output (toOutput v)) oldbuf atomically $ putTMVar bv newbuf -- | This must be used to wait for processes started with -- cgit v1.2.3 From b218820da0b069e826507150cba118f0fa69d409 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 1 Nov 2015 11:30:25 -0400 Subject: take dkim out of test mode --- src/Propellor/Property/SiteSpecific/JoeySites.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index d6db6813..d6a50309 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -738,7 +738,7 @@ dkimInstalled = go `onChange` Service.restarted "opendkim" -- This value can be included in a domain's additional records to make -- it use this domainkey. domainKey :: (BindDomain, Record) -domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") +domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") hasJoeyCAChain :: Property HasInfo hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` -- cgit v1.2.3