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/Spin.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src/Propellor/Spin.hs') 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/Propellor/Spin.hs') 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/Propellor/Spin.hs') 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/Propellor/Spin.hs') 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/Propellor/Spin.hs') 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