From b1f3e9a766b1b245ced1e2963f8f8997cc9fd8eb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 13:43:20 -0400 Subject: [PATCH 01/14] propellor spin --- config-joey.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/config-joey.hs b/config-joey.hs index 50e712a..28f3377 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -503,6 +503,8 @@ monsters = -- but do want to track their public keys etc. , host "turtle.kitenet.net" & ipv4 "67.223.19.96" & ipv6 "2001:4978:f:2d9::2" + , host "butterfly.kitenet.net" + & ipv6 "2001:4830:1600:187::2" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" , host "animx" From cc82993feedda8067897672289db3e6702975081 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 17:26:40 -0400 Subject: [PATCH 02/14] propellor spin --- config-joey.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config-joey.hs b/config-joey.hs index 28f3377..fc7791c 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -503,7 +503,7 @@ monsters = -- but do want to track their public keys etc. , host "turtle.kitenet.net" & ipv4 "67.223.19.96" & ipv6 "2001:4978:f:2d9::2" - , host "butterfly.kitenet.net" + , host "honeybee.kitenet.net" & ipv6 "2001:4830:1600:187::2" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" From b4fdd1f2850ea22e74085e17f488894c45dd0abf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 17:48:19 -0400 Subject: [PATCH 03/14] propellor spin --- config-joey.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/config-joey.hs b/config-joey.hs index fc7791c..197e6e8 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -310,6 +310,7 @@ beaver = host "beaver.kitenet.net" -- Branchable is not completely deployed with propellor yet. pell :: Host pell = host "pell.branchable.com" + & alias "branchable.com" & ipv4 "66.228.46.55" & ipv6 "2600:3c03::f03c:91ff:fedf:c0e5" From a9086c0eea725c8d093a06d0a5dab53b4bcf099a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 18:02:49 -0400 Subject: [PATCH 04/14] propellor spin --- config-joey.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/config-joey.hs b/config-joey.hs index 197e6e8..4978c8a 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -45,6 +45,7 @@ hosts = -- (o) ` , gnu , clam , orca + , honeybee , kite , elephant , beaver @@ -133,6 +134,13 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64" & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer "i386" 15 "2h") & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer (Cron.Times "1 1 * * *") "3h") +honeybee :: Host +honeybee = standardSystem "honeybee.kitenet.net" Unstable "armhf" + [ "Arm git-annex build box." ] + & ipv6 "2001:4830:1600:187::2" + + & Postfix.satellite + -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed -- with propellor. @@ -504,8 +512,6 @@ monsters = -- but do want to track their public keys etc. , host "turtle.kitenet.net" & ipv4 "67.223.19.96" & ipv6 "2001:4978:f:2d9::2" - , host "honeybee.kitenet.net" - & ipv6 "2001:4830:1600:187::2" , host "mouse.kitenet.net" & ipv6 "2001:4830:1600:492::2" , host "animx" From 78fecfcba47901c6c3ff5087cc091d802c5c99d2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 19:18:35 -0400 Subject: [PATCH 05/14] propellor spin --- config-joey.hs | 24 +++++++++++++++---- .../Property/SiteSpecific/GitAnnexBuilder.hs | 20 ++++++++-------- 2 files changed, 30 insertions(+), 14 deletions(-) diff --git a/config-joey.hs b/config-joey.hs index 4978c8a..92a6c31 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -129,17 +129,33 @@ orca = standardSystem "orca.kitenet.net" Unstable "amd64" & Apt.unattendedUpgrades & Postfix.satellite + & Apt.serviceInstalledRunning "ntp" & Systemd.persistentJournal - & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer "amd64" 15 "2h") - & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer "i386" 15 "2h") - & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer (Cron.Times "1 1 * * *") "3h") + + & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer + (System (Debian Testing) "amd64") fifteenpast "2h") + & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer + (System (Debian Testing) "i386") fifteenpast "2h") + & Systemd.nspawned (GitAnnexBuilder.androidAutoBuilderContainer + (Cron.Times "1 1 * * *") "3h") + where + fifteenpast = Cron.Times "15 * * * *" honeybee :: Host -honeybee = standardSystem "honeybee.kitenet.net" Unstable "armhf" +honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf" [ "Arm git-annex build box." ] & ipv6 "2001:4830:1600:187::2" + -- No unattended upgrades as there is currently no console access. + -- (Also, system is not currently running a stock kernel, + -- although it should be able to.) & Postfix.satellite + & Apt.serviceInstalledRunning "ntp" + & Apt.serviceInstalledRunning "aiccu" + + -- Using unstable to get new enough ghc for TH on arm. + & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer + (System (Debian Unstable) "armel") (Cron.Daily) "22h") -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 86bf104..6b73bee 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -94,19 +94,19 @@ cabalDeps = flagFile go cabalupdated go = userScriptProperty (User builduser) ["cabal update && cabal install git-annex --only-dependencies || true"] cabalupdated = homedir ".cabal" "packages" "hackage.haskell.org" "00-index.cache" -standardAutoBuilderContainer :: Architecture -> Int -> TimeOut -> Systemd.Container -standardAutoBuilderContainer arch buildminute timeout = Systemd.container name bootstrap - & os osver - & Apt.stdSourcesList - & Apt.unattendedUpgrades - & User.accountFor (User builduser) - & tree arch - & buildDepsApt - & autobuilder arch (Cron.Times $ show buildminute ++ " * * * *") timeout +standardAutoBuilderContainer :: System -> Times -> TimeOut -> Systemd.Container +standardAutoBuilderContainer osver@(System _ arch) crontime timeout = + Systemd.container name bootstrap + & os osver + & Apt.stdSourcesList + & Apt.unattendedUpgrades + & User.accountFor (User builduser) + & tree arch + & buildDepsApt + & autobuilder arch crontime timeout where name = arch ++ "-git-annex-builder" bootstrap = Chroot.debootstrapped osver mempty - osver = System (Debian Testing) arch androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout = From b5a8c7227b15bb4c821221c6f4c3ca8fd1e1a062 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 22:51:32 -0400 Subject: [PATCH 06/14] workaround bug --- config-joey.hs | 11 +++++++++-- .../Property/SiteSpecific/GitAnnexBuilder.hs | 11 ++++++++--- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/config-joey.hs b/config-joey.hs index 92a6c31..510fd8d 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -25,6 +25,7 @@ import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald +import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode @@ -153,9 +154,15 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf" & Apt.serviceInstalledRunning "ntp" & Apt.serviceInstalledRunning "aiccu" + -- Not using systemd-nspawn because it's broken (kernel issue?) + -- & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer + -- osver Cron.Daily "22h") + & Chroot.provisioned + (Chroot.debootstrapped builderos mempty "/var/lib/containers/armel-git-annex-builder" + & GitAnnexBuilder.standardAutoBuilder builderos Cron.Daily "22h") + where -- Using unstable to get new enough ghc for TH on arm. - & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer - (System (Debian Unstable) "armel") (Cron.Daily) "22h") + builderos = System (Debian Unstable) "armel" -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 6b73bee..3c63872 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -97,6 +97,14 @@ cabalDeps = flagFile go cabalupdated standardAutoBuilderContainer :: System -> Times -> TimeOut -> Systemd.Container standardAutoBuilderContainer osver@(System _ arch) crontime timeout = Systemd.container name bootstrap + & standardAutoBuilder osver crontime timeout + where + name = arch ++ "-git-annex-builder" + bootstrap = Chroot.debootstrapped osver mempty + +standardAutoBuilder :: System -> Times -> TimeOut -> Property HasInfo +standardAutoBuilder osver@(System _ arch) crontime timeout = + propertyList "git-annex-builder" $ props & os osver & Apt.stdSourcesList & Apt.unattendedUpgrades @@ -104,9 +112,6 @@ standardAutoBuilderContainer osver@(System _ arch) crontime timeout = & tree arch & buildDepsApt & autobuilder arch crontime timeout - where - name = arch ++ "-git-annex-builder" - bootstrap = Chroot.debootstrapped osver mempty androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout = From ea1598768c4c4b6b4f45148b0940641c5f9f85d2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 22:52:46 -0400 Subject: [PATCH 07/14] Fix Postfix.satellite bug; the default relayhost was set to the domain, not to smtp.domain as documented. --- debian/changelog | 2 ++ src/Propellor/Property/Postfix.hs | 7 ++++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/debian/changelog b/debian/changelog index 5d70582..e40f5d3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -9,6 +9,8 @@ propellor (2.5.0) UNRELEASED; urgency=medium your own Properties when using propellor as a library. * Improve enter-machine scripts for nspawn containers to unset most environment variables. + * Fix Postfix.satellite bug; the default relayhost was set to the + domain, not to smtp.domain as documented. -- Joey Hess Thu, 07 May 2015 12:08:34 -0400 diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index 073d5dc..b51f4df 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -22,7 +22,8 @@ reloaded :: Property NoInfo reloaded = Service.reloaded "postfix" -- | Configures postfix as a satellite system, which --- relays all mail through a relay host, which defaults to smtp.domain. +-- relays all mail through a relay host, which defaults to smtp.domain, +-- but can be changed by mainCf "relayhost" -- -- The smarthost may refuse to relay mail on to other domains, without -- futher coniguration/keys. But this should be enough to get cron job @@ -34,14 +35,14 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup setup = trivial $ property "postfix satellite system" $ do hn <- asks hostName let (_, domain) = separate (== '.') hn - ensureProperties + ensureProperties [ Apt.reConfigure "postfix" [ ("postfix/main_mailer_type", "select", "Satellite system") , ("postfix/root_address", "string", "root") , ("postfix/destinations", "string", "localhost") , ("postfix/mailname", "string", hn) ] - , mainCf ("relayhost", domain) + , mainCf ("relayhost", "smtp." ++ domain) `onChange` reloaded ] From 02429f7ab103130c28d10e70fec96419024162a8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 23:07:20 -0400 Subject: [PATCH 08/14] propellor spin From c67691f1aa202ae737264c68fe6f762dfe1b0481 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 29 May 2015 23:12:23 -0400 Subject: [PATCH 09/14] propellor spin --- config-joey.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config-joey.hs b/config-joey.hs index 510fd8d..73c9687 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -158,7 +158,7 @@ honeybee = standardSystem "honeybee.kitenet.net" Testing "armhf" -- & Systemd.nspawned (GitAnnexBuilder.standardAutoBuilderContainer -- osver Cron.Daily "22h") & Chroot.provisioned - (Chroot.debootstrapped builderos mempty "/var/lib/containers/armel-git-annex-builder" + (Chroot.debootstrapped builderos mempty "/var/lib/container/armel-git-annex-builder" & GitAnnexBuilder.standardAutoBuilder builderos Cron.Daily "22h") where -- Using unstable to get new enough ghc for TH on arm. From 95b6d711e7da7f13d064086b30727e00ad72ecf5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 30 May 2015 10:26:43 -0400 Subject: [PATCH 10/14] Mount /proc inside a chroot before provisioning it, to work around #787227 --- debian/changelog | 1 + src/Propellor/Property/Chroot.hs | 13 +++++++++++-- src/Propellor/Property/Debootstrap.hs | 4 +--- src/Propellor/Property/Mount.hs | 11 +++++++++++ 4 files changed, 24 insertions(+), 5 deletions(-) diff --git a/debian/changelog b/debian/changelog index e40f5d3..d18d61c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -11,6 +11,7 @@ propellor (2.5.0) UNRELEASED; urgency=medium environment variables. * Fix Postfix.satellite bug; the default relayhost was set to the domain, not to smtp.domain as documented. + * Mount /proc inside a chroot before provisioning it, to work around #787227 -- Joey Hess Thu, 07 May 2015 12:08:34 -0400 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index ec2b667..0e9d00d 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -16,6 +16,7 @@ import Propellor import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Property.Chroot.Util +import Propellor.Property.Mount import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd import qualified Propellor.Shim as Shim @@ -55,8 +56,9 @@ debootstrapped system conf location = case system of -- | Ensures that the chroot exists and is provisioned according to its -- properties. -- --- Reverting this property removes the chroot. Note that it does not ensure --- that any processes that might be running inside the chroot are stopped. +-- 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 c = provisioned' (propigateChrootInfo c) c False @@ -101,6 +103,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " ( pure (Shim.file me d) , Shim.setup me Nothing d ) + liftIO mountproc ifM (liftIO $ bindmount shim) ( chainprovision shim , return FailedChange @@ -117,6 +120,12 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " ] ) + -- /proc needs to be mounted in the chroot for the linker to use + -- /proc/self/exe which is necessary for some commands to work + mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ + void $ mount "proc" "proc" procloc + procloc = loc "proc" + chainprovision shim = do parenthost <- asks hostName cmd <- liftIO $ toChain parenthost c systemdonly diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index f29ae56..8d974eb 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -106,9 +106,7 @@ unpopulated d = null <$> catchDefaultIO [] (dirContents d) removetarget :: FilePath -> IO () removetarget target = do - submnts <- filter (\p -> simplifyPath p /= simplifyPath target) - . filter (dirContains target) - <$> mountPoints + submnts <- mountPointsBelow target forM_ submnts umountLazy removeDirectoryRecursive target diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index a081b1e..ff47f4d 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,22 +1,33 @@ module Propellor.Property.Mount where import Propellor +import Utility.Path type FsType = String type Source = String +-- | Lists all mount points of the system. mountPoints :: IO [FilePath] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] +-- | Finds all filesystems mounted inside the specified directory. +mountPointsBelow :: FilePath -> IO [FilePath] +mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + +-- | Filesystem type mounted at a given location. getFsType :: FilePath -> IO (Maybe FsType) getFsType mnt = catchDefaultIO Nothing $ headMaybe . lines <$> readProcess "findmnt" ["-n", mnt, "--output", "fstype"] +-- | Unmounts a device, lazily so any running processes don't block it. umountLazy :: FilePath -> IO () umountLazy mnt = unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ errorMessage $ "failed unmounting " ++ mnt +-- | Mounts a device. mount :: FsType -> Source -> FilePath -> IO Bool mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt] From 4ba6df400da254a136d54531f315ab2349eea074 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 30 May 2015 10:27:35 -0400 Subject: [PATCH 11/14] propellor spin From 6bb17a114f8f8d0807915b739c2eb0d01f16f5d9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 30 May 2015 10:30:28 -0400 Subject: [PATCH 12/14] propellor spin From 354803328067c261f439b7a8046717320cfd557c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 30 May 2015 10:32:42 -0400 Subject: [PATCH 13/14] propellor spin From aa7dcad9ba8d14013f26f6e8554901d56ef4cb5c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 30 May 2015 11:05:34 -0400 Subject: [PATCH 14/14] export createProcess with debug logging from Propellor.Property.Cmd --- debian/changelog | 7 +-- src/Propellor/Property/Cmd.hs | 5 ++- src/Utility/Process.hs | 80 +++++++++++++++++------------------ 3 files changed, 47 insertions(+), 45 deletions(-) diff --git a/debian/changelog b/debian/changelog index d18d61c..9fae861 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,9 +4,10 @@ propellor (2.5.0) UNRELEASED; urgency=medium more generic cmdProperty' (API change) * Add docker image related properties. Thanks, Antoine Eiche. - * Export CommandParam, boolSystem, safeSystem and shellEscape from - Propellor.Property.Cmd, so they are available for use in constricting - your own Properties when using propellor as a library. + * Export CommandParam, boolSystem, safeSystem, shellEscape, and + * createProcess from Propellor.Property.Cmd, so they are available + for use in constricting your own Properties when using propellor + as a library. * Improve enter-machine scripts for nspawn containers to unset most environment variables. * Fix Postfix.satellite bug; the default relayhost was set to the diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 23f1075..23816a9 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -14,18 +14,19 @@ module Propellor.Property.Cmd ( boolSystemEnv, safeSystem, safeSystemEnv, - shellEscape + shellEscape, + createProcess, ) where import Control.Applicative import Data.List import "mtl" Control.Monad.Reader -import System.Process (CreateProcess) import Propellor.Types import Propellor.Property import Utility.SafeCommand import Utility.Env +import Utility.Process (createProcess, CreateProcess) -- | A property that can be satisfied by running a command. -- diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index 9f98596..469f765 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -1,7 +1,7 @@ {- System.Process enhancements, including additional ways of running - processes, and logging. - - - Copyright 2012 Joey Hess + - Copyright 2012-2015 Joey Hess - - License: BSD-2-clause -} @@ -65,8 +65,8 @@ type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Hand data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) -{- Normally, when reading from a process, it does not need to be fed any - - standard input. -} +-- | Normally, when reading from a process, it does not need to be fed any +-- standard input. readProcess :: FilePath -> [String] -> IO String readProcess cmd args = readProcessEnv cmd args Nothing @@ -84,9 +84,8 @@ readProcess' p = withHandle StdoutHandle createProcessSuccess p $ \h -> do hClose h return output -{- Runs an action to write to a process on its stdin, - - returns its output, and also allows specifying the environment. - -} +-- | Runs an action to write to a process on its stdin, +-- returns its output, and also allows specifying the environment. writeReadProcessEnv :: FilePath -> [String] @@ -126,8 +125,8 @@ writeReadProcessEnv cmd args environ writestdin adjusthandle = do , env = environ } -{- Waits for a ProcessHandle, and throws an IOError if the process - - did not exit successfully. -} +-- | Waits for a ProcessHandle, and throws an IOError if the process +-- did not exit successfully. forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO () forceSuccessProcess p pid = do code <- waitForProcess pid @@ -135,10 +134,10 @@ forceSuccessProcess p pid = do ExitSuccess -> return () ExitFailure n -> fail $ showCmd p ++ " exited " ++ show n -{- Waits for a ProcessHandle and returns True if it exited successfully. - - Note that using this with createProcessChecked will throw away - - the Bool, and is only useful to ignore the exit code of a process, - - while still waiting for it. -} +-- | Waits for a ProcessHandle and returns True if it exited successfully. +-- Note that using this with createProcessChecked will throw away +-- the Bool, and is only useful to ignore the exit code of a process, +-- while still waiting for it. -} checkSuccessProcess :: ProcessHandle -> IO Bool checkSuccessProcess pid = do code <- waitForProcess pid @@ -149,13 +148,13 @@ ignoreFailureProcess pid = do void $ waitForProcess pid return True -{- Runs createProcess, then an action on its handles, and then - - forceSuccessProcess. -} +-- | Runs createProcess, then an action on its handles, and then +-- forceSuccessProcess. createProcessSuccess :: CreateProcessRunner createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a -{- Runs createProcess, then an action on its handles, and then - - a checker action on its exit code, which must wait for the process. -} +-- | Runs createProcess, then an action on its handles, and then +-- a checker action on its exit code, which must wait for the process. createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner createProcessChecked checker p a = do t@(_, _, _, pid) <- createProcess p @@ -163,14 +162,14 @@ createProcessChecked checker p a = do _ <- checker pid either E.throw return r -{- Leaves the process running, suitable for lazy streaming. - - Note: Zombies will result, and must be waited on. -} +-- | Leaves the process running, suitable for lazy streaming. +-- Note: Zombies will result, and must be waited on. createBackgroundProcess :: CreateProcessRunner createBackgroundProcess p a = a =<< createProcess p -{- Runs a process, optionally feeding it some input, and - - returns a transcript combining its stdout and stderr, and - - whether it succeeded or failed. -} +-- | Runs a process, optionally feeding it some input, and +-- returns a transcript combining its stdout and stderr, and +-- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) processTranscript cmd opts input = processTranscript' cmd opts Nothing input @@ -234,9 +233,9 @@ processTranscript' cmd opts environ input = do hClose inh writeinput Nothing _ = return () -{- Runs a CreateProcessRunner, on a CreateProcess structure, that - - is adjusted to pipe only from/to a single StdHandle, and passes - - the resulting Handle to an action. -} +-- | Runs a CreateProcessRunner, on a CreateProcess structure, that +-- is adjusted to pipe only from/to a single StdHandle, and passes +-- the resulting Handle to an action. withHandle :: StdHandle -> CreateProcessRunner @@ -258,7 +257,7 @@ withHandle h creator p a = creator p' $ a . select | h == StderrHandle = (stderrHandle, base { std_err = CreatePipe }) -{- Like withHandle, but passes (stdin, stdout) handles to the action. -} +-- | Like withHandle, but passes (stdin, stdout) handles to the action. withIOHandles :: CreateProcessRunner -> CreateProcess @@ -272,7 +271,7 @@ withIOHandles creator p a = creator p' $ a . ioHandles , std_err = Inherit } -{- Like withHandle, but passes (stdout, stderr) handles to the action. -} +-- | Like withHandle, but passes (stdout, stderr) handles to the action. withOEHandles :: CreateProcessRunner -> CreateProcess @@ -286,8 +285,8 @@ withOEHandles creator p a = creator p' $ a . oeHandles , std_err = CreatePipe } -{- Forces the CreateProcessRunner to run quietly; - - both stdout and stderr are discarded. -} +-- | Forces the CreateProcessRunner to run quietly; +-- both stdout and stderr are discarded. withQuietOutput :: CreateProcessRunner -> CreateProcess @@ -299,8 +298,8 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do } creator p' $ const $ return () -{- Stdout and stderr are discarded, while the process is fed stdin - - from the handle. -} +-- | Stdout and stderr are discarded, while the process is fed stdin +-- from the handle. feedWithQuietOutput :: CreateProcessRunner -> CreateProcess @@ -321,11 +320,11 @@ devNull = "/dev/null" devNull = "NUL" #endif -{- Extract a desired handle from createProcess's tuple. - - These partial functions are safe as long as createProcess is run - - with appropriate parameters to set up the desired handle. - - Get it wrong and the runtime crash will always happen, so should be - - easily noticed. -} +-- | Extract a desired handle from createProcess's tuple. +-- These partial functions are safe as long as createProcess is run +-- with appropriate parameters to set up the desired handle. +-- Get it wrong and the runtime crash will always happen, so should be +-- easily noticed. type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle stdinHandle :: HandleExtractor stdinHandle (Just h, _, _, _) = h @@ -346,7 +345,7 @@ oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid -{- Debugging trace for a CreateProcess. -} +-- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () debugProcess p = do debugM "Utility.Process" $ unwords @@ -362,15 +361,15 @@ debugProcess p = do piped Inherit = False piped _ = True -{- Shows the command that a CreateProcess will run. -} +-- | Shows the command that a CreateProcess will run. showCmd :: CreateProcess -> String showCmd = go . cmdspec where go (ShellCommand s) = s go (RawCommand c ps) = c ++ " " ++ show ps -{- Starts an interactive process. Unlike runInteractiveProcess in - - System.Process, stderr is inherited. -} +-- | Starts an interactive process. Unlike runInteractiveProcess in +-- System.Process, stderr is inherited. startInteractiveProcess :: FilePath -> [String] @@ -386,7 +385,8 @@ startInteractiveProcess cmd args environ = do (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) -{- Wrapper around System.Process function that does debug logging. -} +-- | Wrapper around 'System.Process.createProcess' from System.Process, +-- that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p