From 08010583fa42af1b2b5ab070e4742263d43b26cf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 12 Jul 2017 19:12:36 -0400 Subject: add bootstrapWith property to support stack and more * Hosts can be configured to build propellor using stack, by adding a property: & bootstrapWith (Robustly Stack) * Hosts can be configured to build propellor using cabal, but using only packages installed from the operating system. This will work on eg Debian: & bootstrapWith OSOnly propellor build its config using stack. (This does not affect how propellor is bootstrapped on a host by "propellor --spin host".) This has not yet been tested at all! But should probably work fine. This is based on earlier work by Arnaud Bailly, who made Propellor.Bootstrap use stack without parameterization. In Arnaud's patch, stack was installed using wget, but that only worked on linux-x86_64 and was insecure. I instead chose to use the distribution packages of stack, like is done for cabal. Debian stack has haskell-stack now, and it's getting into many distributions. This commit was sponsored by Francois Marier on Patreon. --- src/Propellor/Bootstrap.hs | 167 ++++++++++++++++++++++++++---------- src/Propellor/Property/Bootstrap.hs | 45 ++++++++-- src/Propellor/Property/Cron.hs | 5 +- src/Propellor/Spin.hs | 5 +- 4 files changed, 165 insertions(+), 57 deletions(-) (limited to 'src') diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 4b3f2da2..baf36e49 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -1,4 +1,8 @@ module Propellor.Bootstrap ( + Bootstrapper(..), + Builder(..), + defaultBootstrapper, + getBootstrapper, bootstrapPropellorCommand, checkBinaryCommand, installGitCommand, @@ -16,71 +20,120 @@ import Data.List type ShellCommand = String +-- | Different ways that Propellor's dependencies can be installed, +-- and propellor can be built. The default is `Robustly Cabal` +-- +-- `Robustly Cabal` and `Robustly Stack` use the OS's native packages +-- as much as possible to install Cabal, Stack, and propellor's build +-- dependencies. When necessary, dependencies are built from source +-- using Cabal or Stack rather than using the OS's native packages. +-- +-- `OSOnly` uses the OS's native packages of Cabal and all of propellor's +-- build dependencies. It may not work on all systems. +data Bootstrapper = Robustly Builder | OSOnly + deriving (Show) + +data Builder = Cabal | Stack + deriving (Show) + +defaultBootstrapper :: Bootstrapper +defaultBootstrapper = Robustly Cabal + +-- | Gets the Bootstrapper for the Host propellor is running on. +getBootstrapper :: Propellor Bootstrapper +getBootstrapper = go <$> askInfo + where + go NoInfoVal = defaultBootstrapper + go (InfoVal bs) = bs + +getBuilder :: Bootstrapper -> Builder +getBuilder (Robustly b) = b +getBuilder OSOnly = Cabal + -- Shell command line to ensure propellor is bootstrapped and ready to run. -- Should be run inside the propellor config dir, and will install -- all necessary build dependencies and build propellor. -bootstrapPropellorCommand :: Maybe System -> ShellCommand -bootstrapPropellorCommand msys = checkDepsCommand msys ++ +bootstrapPropellorCommand :: Bootstrapper -> Maybe System -> ShellCommand +bootstrapPropellorCommand bs msys = checkDepsCommand bs msys ++ "&& if ! test -x ./propellor; then " - ++ buildCommand ++ - "; fi;" ++ checkBinaryCommand + ++ buildCommand bs ++ + "; fi;" ++ checkBinaryCommand bs -- Use propellor --check to detect if the local propellor binary has -- stopped working (eg due to library changes), and must be rebuilt. -checkBinaryCommand :: ShellCommand -checkBinaryCommand = "if test -x ./propellor && ! ./propellor --check; then " ++ go ++ "; fi" +checkBinaryCommand :: Bootstrapper -> ShellCommand +checkBinaryCommand bs = "if test -x ./propellor && ! ./propellor --check; then " ++ go (getBuilder bs) ++ "; fi" where - go = intercalate " && " + go Cabal = intercalate " && " [ "cabal clean" - , buildCommand + , buildCommand bs + ] + go Stack = intercalate " && " + [ "stack clean" + , buildCommand bs ] -buildCommand :: ShellCommand -buildCommand = intercalate " && " - [ "cabal configure" - , "cabal build propellor-config" - , "ln -sf dist/build/propellor-config/propellor-config propellor" - ] +buildCommand :: Bootstrapper -> ShellCommand +buildCommand bs = intercalate " && " (go (getBuilder bs)) + where + go Cabal = + [ "cabal configure" + , "cabal build propellor-config" + , "ln -sf dist/build/propellor-config/propellor-config propellor" + ] + go Stack = + [ "stack build :propellor-config" + , "ln -sf $(stack path --dist-dir)/build/propellor-config propellor" + ] -- Run cabal configure to check if all dependencies are installed; -- if not, run the depsCommand. -checkDepsCommand :: Maybe System -> ShellCommand -checkDepsCommand sys = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand sys ++ "; fi" +checkDepsCommand :: Bootstrapper -> Maybe System -> ShellCommand +checkDepsCommand bs sys = go (getBuilder bs) + where + go Cabal = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" + go Stack = "if ! stack --version >/dev/null 2>&1; then " ++ depsCommand bs sys ++ "; fi" --- Install build dependencies of propellor. --- --- First, try to install ghc, cabal, gnupg, and all haskell libraries that --- propellor uses from OS packages. +-- Install build dependencies of propellor, using the specified +-- Bootstrapper. -- +-- When bootstrapping Robustly, first try to install the builder, +-- and all haskell libraries that propellor uses from OS packages. -- Some packages may not be available in some versions of Debian -- (eg, Debian wheezy lacks async), or propellor may need a newer version. --- So, as a second step, cabal is used to install all dependencies. +-- So, as a second step, any other dependencies are installed from source +-- using the builder. -- -- Note: May succeed and leave some deps not installed. -depsCommand :: Maybe System -> ShellCommand -depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " ) || true" +depsCommand :: Bootstrapper -> Maybe System -> ShellCommand +depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" where - osinstall = case msys of - Just (System (FreeBSD _) _) -> map pkginstall fbsddeps - Just (System (ArchLinux) _) -> map pacmaninstall archlinuxdeps - Just (System (Debian _ _) _) -> useapt - Just (System (Buntish _) _) -> useapt - -- assume a debian derived system when not specified - Nothing -> useapt - - useapt = "apt-get update" : map aptinstall debdeps - - cabalinstall = + go (Robustly Cabal) = osinstall Cabal ++ [ "cabal update" , "cabal install --only-dependencies" + ] + go (Robustly Stack) = osinstall Stack ++ + [ "stack setup" + , "stack build --only-dependencies :propellor-config" ] + go OSOnly = osinstall Cabal + + osinstall builder = case msys of + Just (System (FreeBSD _) _) -> map pkginstall (fbsddeps builder) + Just (System (ArchLinux) _) -> map pacmaninstall (archlinuxdeps builder) + Just (System (Debian _ _) _) -> useapt builder + Just (System (Buntish _) _) -> useapt builder + -- assume a Debian derived system when not specified + Nothing -> useapt builder + + useapt builder = "apt-get update" : map aptinstall (debdeps builder) aptinstall p = "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-upgrade --no-install-recommends -y install " ++ p pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p pacmaninstall p = "pacman -S --noconfirm --needed " ++ p -- This is the same deps listed in debian/control. - debdeps = + debdeps Cabal = [ "gnupg" , "ghc" , "cabal-install" @@ -98,7 +151,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "libghc-text-dev" , "libghc-hashable-dev" ] - fbsddeps = + debdeps Stack = + [ "gnupg" + , "haskell-stack" + ] + + fbsddeps Cabal = [ "gnupg" , "ghc" , "hs-cabal-install" @@ -116,7 +174,12 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "hs-text" , "hs-hashable" ] - archlinuxdeps = + fbsddeps Stack = + [ "gnupg" + , "stack" + ] + + archlinuxdeps Cabal = [ "gnupg" , "ghc" , "cabal-install" @@ -135,6 +198,10 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "haskell-text" , "hashell-hashable" ] + archlinuxdeps Stack = + [ "gnupg" + , "stack" + ] installGitCommand :: Maybe System -> ShellCommand installGitCommand msys = case msys of @@ -155,22 +222,28 @@ installGitCommand msys = case msys of , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" ] +-- Build propellor, and symlink the built binary to ./propellor. +-- +-- When the Host has a Buildsystem specified it is used. If none is +-- specified, look at git config propellor.buildsystem. buildPropellor :: Maybe Host -> IO () -buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ +buildPropellor mh = unlessM (actionMessage "Propellor build" build) $ errorMessage "Propellor build failed!" where msys = case fmap (fromInfo . hostInfo) mh of Just (InfoVal sys) -> Just sys _ -> Nothing --- Build propellor using cabal or stack, and symlink propellor to the --- built binary. -build :: Maybe System -> IO Bool -build msys = catchBoolIO $ do - bs <- getGitConfigValue "propellor.buildsystem" - case bs of - Just "stack" -> stackBuild msys - _ -> cabalBuild msys + build = catchBoolIO $ do + case fromInfo (maybe mempty hostInfo mh) of + NoInfoVal -> do + bs <- getGitConfigValue "propellor.buildsystem" + case bs of + Just "stack" -> stackBuild msys + _ -> cabalBuild msys + InfoVal bs -> case getBuilder bs of + Cabal -> cabalBuild msys + Stack -> stackBuild msys -- For speed, only runs cabal configure when it's not been run before. -- If the build fails cabal may need to have configure re-run. @@ -203,7 +276,7 @@ cabalBuild msys = do , case msys of Nothing -> return False Just sys -> - boolSystem "sh" [Param "-c", Param (depsCommand (Just sys))] + boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))] <&&> cabal ["configure"] ) cabal_build = cabal ["build", "propellor-config"] diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs index 767d6ef7..93529c14 100644 --- a/src/Propellor/Property/Bootstrap.hs +++ b/src/Propellor/Property/Bootstrap.hs @@ -1,12 +1,39 @@ -module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where +-- | This module contains properties that configure how Propellor +-- bootstraps to run itself on a Host. + +module Propellor.Property.Bootstrap ( + Bootstrapper(..), + bootstrapWith, + RepoSource(..), + bootstrappedFrom, + clonedFrom +) where import Propellor.Base import Propellor.Bootstrap +import Propellor.Types.Info import Propellor.Property.Chroot import Data.List import qualified Data.ByteString as B +-- | This property can be used to configure the `Bootstrapper` that is used +-- to bootstrap propellor on a Host. For example, if you want to use +-- stack: +-- +-- > host "example.com" $ props +-- > & bootstrapWith (Robustly Stack) +-- +-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, +-- this property can also be added to the chroot to configure it. +bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike) +bootstrapWith b = pureInfoProperty desc (InfoVal b) + where + desc = "bootstrapped with " ++ case b of + Robustly Stack -> "stack" + Robustly Cabal -> "cabal" + OSOnly -> "OS packages only" + -- | Where a propellor repository should be bootstrapped from. data RepoSource = GitRepoUrl String @@ -17,14 +44,17 @@ data RepoSource -- | Bootstraps a propellor installation into -- /usr/local/propellor/ -- --- This property only does anything when used inside a chroot. --- This is particularly useful inside a chroot used to build a +-- Normally, propellor is bootstrapped by eg, using propellor --spin, +-- and so this property is not generally needed. +-- +-- This property only does anything when used inside a Chroot or other +-- Container. This is particularly useful inside a chroot used to build a -- disk image, to make the disk image have propellor installed. -- -- The git repository is cloned (or pulled to update if it already exists). -- -- All build dependencies are installed, using distribution packages --- or falling back to using cabal. +-- or falling back to using cabal or stack. bootstrappedFrom :: RepoSource -> Property Linux bootstrappedFrom reposource = check inChroot $ go `requires` clonedFrom reposource @@ -32,14 +62,15 @@ bootstrappedFrom reposource = check inChroot $ go :: Property Linux go = property "Propellor bootstrapped" $ do system <- getOS + bootstrapper <- getBootstrapper assumeChange $ exposeTrueLocaldir $ const $ runShellCommand $ buildShellCommand [ "cd " ++ localdir - , checkDepsCommand system - , buildCommand + , checkDepsCommand bootstrapper system + , buildCommand bootstrapper ] --- | Clones the propellor repeository into /usr/local/propellor/ +-- | Clones the propellor repository into /usr/local/propellor/ -- -- If the propellor repo has already been cloned, pulls to get it -- up-to-date. diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index 0966a7e5..ab700a9d 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -80,7 +80,8 @@ niceJob desc times user cddir command = job desc times user cddir -- | Installs a cron job to run propellor. runPropellor :: Times -> Property UnixLike -runPropellor times = withOS "propellor cron job" $ \w o -> +runPropellor times = withOS "propellor cron job" $ \w o -> do + bootstrapper <- getBootstrapper ensureProperty w $ niceJob "propellor" times (User "root") localdir - (bootstrapPropellorCommand o ++ "; ./propellor") + (bootstrapPropellorCommand bootstrapper o ++ "; ./propellor") diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index cd964e16..7146ad4c 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -93,6 +93,9 @@ spin' mprivdata relay target hst = do sys = case fromInfo (hostInfo hst) of InfoVal o -> Just o NoInfoVal -> Nothing + bootstrapper = case fromInfo (hostInfo hst) of + NoInfoVal -> defaultBootstrapper + InfoVal bs -> bs relaying = relay == Just target viarelay = isJust relay && not relaying @@ -109,7 +112,7 @@ spin' mprivdata relay target hst = do updatecmd = intercalate " && " [ "cd " ++ localdir - , bootstrapPropellorCommand sys + , bootstrapPropellorCommand bootstrapper sys , if viarelay then "./propellor --continue " ++ shellEscape (show (Relay target)) -- cgit v1.2.3 From 632137836b39462883483a621f9dd696ce1d73cc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Jul 2017 11:04:14 -0400 Subject: disable buffering earlier The "fatal: Couldn't find remote ref HEAD" persists, and is intermittent so hard to be sure but it seemed that disabling buffering earlier avoided it. Now done first thing on start. I was not able to find anything that reads from stdin other than getMarked, but perhaps there is something.. --- src/Propellor/CmdLine.hs | 1 + src/Propellor/Protocol.hs | 6 +----- src/Propellor/Spin.hs | 13 ++++++++++--- 3 files changed, 12 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index a36ec7f5..70bb0bf8 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -111,6 +111,7 @@ data CanRebuild = CanRebuild | NoRebuild defaultMain :: [Host] -> IO () defaultMain hostlist = withConcurrentOutput $ do useFileSystemEncoding + updatePrepare Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs index ae7e0404..bc8d9327 100644 --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -53,11 +53,7 @@ sendMarked' h marker s = do hFlush h getMarked :: Handle -> Marker -> IO (Maybe String) -getMarked h marker = do - -- Avoid buffering anything in Handle, so that the data after - -- the marker will be available to be read from the underlying Fd. - hSetBuffering stdin NoBuffering - go =<< catchMaybeIO (hGetLine h) +getMarked h marker = go =<< catchMaybeIO (hGetLine h) where go Nothing = return Nothing go (Just l) = case fromMarked marker l of diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 7146ad4c..732ec9b7 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -5,6 +5,7 @@ module Propellor.Spin ( spin, spin', update, + updatePrepare, gitPushHelper, mergeSpin, ) where @@ -349,14 +350,20 @@ findLastNonSpinCommit = do spinCommitMessage :: String spinCommitMessage = "propellor spin" +-- Avoid buffering anything read from stdin, so that +-- when gitPullFromUpdateServer runs git fetch, it sees all the data +-- it expects to. +-- +-- Should be called very early in propellor start, before anything reads +-- from stdin. +updatePrepare :: IO () +updatePrepare = hSetBuffering stdin NoBuffering + -- Stdin and stdout are connected to the updateServer over ssh. -- Request that it run git upload-pack, and connect that up to a git fetch -- to receive the data. gitPullFromUpdateServer :: IO () gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do - -- Note that this relies on data not being buffered in the stdin - -- Handle, since such buffered data would not be available in the - -- FD passed to git fetch. hin <- dup stdInput hout <- dup stdOutput hClose stdin -- cgit v1.2.3 From 043cd2218efb8e3d2f04ae2faff38293a01ed0c5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Jul 2017 11:10:27 -0400 Subject: Revert "disable buffering earlier" This reverts commit 632137836b39462883483a621f9dd696ce1d73cc. Still failing :( Seems that disabling buffering is not the solution. --- src/Propellor/CmdLine.hs | 1 - src/Propellor/Protocol.hs | 6 +++++- src/Propellor/Spin.hs | 13 +++---------- 3 files changed, 8 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 70bb0bf8..a36ec7f5 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -111,7 +111,6 @@ data CanRebuild = CanRebuild | NoRebuild defaultMain :: [Host] -> IO () defaultMain hostlist = withConcurrentOutput $ do useFileSystemEncoding - updatePrepare Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs index bc8d9327..ae7e0404 100644 --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -53,7 +53,11 @@ sendMarked' h marker s = do hFlush h getMarked :: Handle -> Marker -> IO (Maybe String) -getMarked h marker = go =<< catchMaybeIO (hGetLine h) +getMarked h marker = do + -- Avoid buffering anything in Handle, so that the data after + -- the marker will be available to be read from the underlying Fd. + hSetBuffering stdin NoBuffering + go =<< catchMaybeIO (hGetLine h) where go Nothing = return Nothing go (Just l) = case fromMarked marker l of diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 732ec9b7..7146ad4c 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -5,7 +5,6 @@ module Propellor.Spin ( spin, spin', update, - updatePrepare, gitPushHelper, mergeSpin, ) where @@ -350,20 +349,14 @@ findLastNonSpinCommit = do spinCommitMessage :: String spinCommitMessage = "propellor spin" --- Avoid buffering anything read from stdin, so that --- when gitPullFromUpdateServer runs git fetch, it sees all the data --- it expects to. --- --- Should be called very early in propellor start, before anything reads --- from stdin. -updatePrepare :: IO () -updatePrepare = hSetBuffering stdin NoBuffering - -- Stdin and stdout are connected to the updateServer over ssh. -- Request that it run git upload-pack, and connect that up to a git fetch -- to receive the data. gitPullFromUpdateServer :: IO () gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do + -- Note that this relies on data not being buffered in the stdin + -- Handle, since such buffered data would not be available in the + -- FD passed to git fetch. hin <- dup stdInput hout <- dup stdOutput hClose stdin -- cgit v1.2.3 From 1555c6f88a0446d3e29149eff8315817696731e1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Jul 2017 11:23:04 -0400 Subject: trying the pipe trick again With some small changes, and debugging. --- src/Propellor/Protocol.hs | 10 +++------- src/Propellor/Spin.hs | 38 ++++++++++++++++++++++++++++++-------- 2 files changed, 33 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs index ae7e0404..e90155f3 100644 --- a/src/Propellor/Protocol.hs +++ b/src/Propellor/Protocol.hs @@ -53,11 +53,7 @@ sendMarked' h marker s = do hFlush h getMarked :: Handle -> Marker -> IO (Maybe String) -getMarked h marker = do - -- Avoid buffering anything in Handle, so that the data after - -- the marker will be available to be read from the underlying Fd. - hSetBuffering stdin NoBuffering - go =<< catchMaybeIO (hGetLine h) +getMarked h marker = go =<< catchMaybeIO (hGetLine h) where go Nothing = return Nothing go (Just l) = case fromMarked marker l of @@ -69,8 +65,8 @@ getMarked h marker = do debug ["received marked", marker] return (Just v) -reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO () -reqMarked stage marker a = do +req :: Stage -> Marker -> (String -> IO ()) -> IO () +req stage marker a = do debug ["requested marked", marker] sendMarked' stdout statusMarker (show stage) maybe noop a =<< getMarked stdin marker diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 7146ad4c..6b6c6d69 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -181,11 +181,11 @@ getSshTarget target hst update :: Maybe HostName -> IO () update forhost = do whenM hasGitRepo $ - reqMarked NeedRepoUrl repoUrlMarker setRepoUrl + req NeedRepoUrl repoUrlMarker setRepoUrl makePrivDataDir createDirectoryIfMissing True (takeDirectory privfile) - reqMarked NeedPrivData privDataMarker $ + req NeedPrivData privDataMarker $ writeFileProtected privfile whenM hasGitRepo $ @@ -353,18 +353,25 @@ spinCommitMessage = "propellor spin" -- Request that it run git upload-pack, and connect that up to a git fetch -- to receive the data. gitPullFromUpdateServer :: IO () -gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do - -- Note that this relies on data not being buffered in the stdin - -- Handle, since such buffered data would not be available in the - -- FD passed to git fetch. - hin <- dup stdInput +gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do + -- IO involving stdin can cause data to be buffered in the Handle + -- (even when it's set NoBuffering), but we need to pass a FD to + -- git fetch containing all of stdin after the gitPushMarker, + -- including any that has been buffered. + -- + -- To do so, create a pipe, and forward stdin, including any + -- buffered part, through it. + (pread, pwrite) <- System.Posix.IO.createPipe + hwrite <- fdToHandle pwrite + forwarder <- async $ stdin *>*! hwrite + let hin = pread hout <- dup stdOutput - hClose stdin hClose stdout -- Not using git pull because git 2.5.0 badly -- broke its option parser. unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $ errorMessage "git fetch from client failed" + wait forwarder unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $ errorMessage "git merge from client failed" where @@ -401,3 +408,18 @@ fromh *>* toh = do B.hPut toh b hFlush toh fromh *>* toh + +(*>*!) :: Handle -> Handle -> IO () +fromh *>*! toh = do + b <- B.hGetSome fromh 40960 + if B.null b + then do + hPutStrLn stderr "EOF on forwarded input" + hClose fromh + hClose toh + else do + hPutStrLn stderr "forwarding input:" + B.hPut stderr b + B.hPut toh b + hFlush toh + fromh *>*! toh -- cgit v1.2.3 From 53fe5ffaac4a243bb9fd3cf0e757128150a6a199 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Jul 2017 12:29:01 -0400 Subject: finally really fixed HEAD problem My first try with a pipe was the right approach, and was almost right, except I forgot to close the write end of the pipe, and so it was inherited by the forked process, leading to deadlock. --- src/Propellor/Spin.hs | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 6b6c6d69..aeaa4643 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -362,8 +362,13 @@ gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do -- To do so, create a pipe, and forward stdin, including any -- buffered part, through it. (pread, pwrite) <- System.Posix.IO.createPipe + -- Note that there is a race between the createPipe and setting + -- CloseOnExec. Another processess forked here would inherit + -- pwrite and perhaps keep it open. However, propellor is not + -- running concurrent threads at this point, so this is ok. + setFdOption pwrite CloseOnExec True hwrite <- fdToHandle pwrite - forwarder <- async $ stdin *>*! hwrite + forwarder <- async $ stdin *>* hwrite let hin = pread hout <- dup stdOutput hClose stdout @@ -408,18 +413,3 @@ fromh *>* toh = do B.hPut toh b hFlush toh fromh *>* toh - -(*>*!) :: Handle -> Handle -> IO () -fromh *>*! toh = do - b <- B.hGetSome fromh 40960 - if B.null b - then do - hPutStrLn stderr "EOF on forwarded input" - hClose fromh - hClose toh - else do - hPutStrLn stderr "forwarding input:" - B.hPut stderr b - B.hPut toh b - hFlush toh - fromh *>*! toh -- cgit v1.2.3