summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Info.hs4
-rw-r--r--src/Propellor/Message.hs4
-rw-r--r--src/Propellor/Protocol.hs10
-rw-r--r--src/Propellor/Spin.hs102
-rw-r--r--src/Propellor/Types/OS.hs2
5 files changed, 68 insertions, 54 deletions
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 49ca689f..ed6c2d85 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -84,13 +84,13 @@ askInfo = asks (fromInfo . hostInfo)
-- It also lets the type checker know that all the properties of the
-- host must support Debian.
--
--- > & osDebian (Stable "jessie") X86_64
+-- > & osDebian (Stable "stretch") X86_64
osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian = osDebian' Linux
-- Use to specify a different `DebianKernel` than the default `Linux`
--
--- > & osDebian' KFreeBSD (Stable "jessie") X86_64
+-- > & osDebian' KFreeBSD (Stable "stretch") X86_64
osDebian' :: DebianKernel -> DebianSuite -> Architecture -> Property (HasInfo + Debian)
osDebian' kernel suite arch = tightenTargets $ os (System (Debian kernel suite) arch)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 97573516..c56f0c5a 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -102,7 +102,7 @@ actionMessage' mhn desc a = do
warningMessage :: MonadIO m => String -> m ()
warningMessage s = liftIO $
- outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
+ errorConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s)
infoMessage :: MonadIO m => [String] -> m ()
infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
@@ -113,7 +113,7 @@ infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls
-- property fail. Propellor will continue to the next property.
errorMessage :: MonadIO m => String -> m a
errorMessage s = liftIO $ do
- outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
+ errorConcurrent =<< colorLine Vivid Red ("** error: " ++ s)
-- Normally this exception gets caught and is not displayed,
-- and propellor continues. So it's only displayed if not
-- caught, and so we say, cannot continue.
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index e90155f3..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
@@ -65,8 +69,8 @@ getMarked h marker = go =<< catchMaybeIO (hGetLine h)
debug ["received marked", marker]
return (Just v)
-req :: Stage -> Marker -> (String -> IO ()) -> IO ()
-req stage marker a = do
+reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
+reqMarked 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 3b3729f9..cd964e16 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -178,34 +178,16 @@ getSshTarget target hst
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
- req NeedRepoUrl repoUrlMarker setRepoUrl
+ reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
- req NeedPrivData privDataMarker $
+ reqMarked NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
- req NeedGitPush gitPushMarker $ \_ -> do
- hin <- dup stdInput
- hout <- dup stdOutput
- hClose stdin
- hClose stdout
- -- Not using git pull because git 2.5.0 badly
- -- broke its option parser.
- unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
- errorMessage "git fetch from client failed"
- unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
- errorMessage "git merge from client failed"
+ gitPullFromUpdateServer
where
- pullparams hin hout =
- [ Param "fetch"
- , Param "--progress"
- , Param "--upload-pack"
- , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
- , Param "."
- ]
-
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
@@ -336,31 +318,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
, "rm -f " ++ remotetarball
]
--- Shim for git push over the propellor ssh channel.
--- Reads from stdin and sends it to hout;
--- reads from hin and sends it to stdout.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
- where
- fromstdin = do
- h <- fdToHandle hout
- connect stdin h
- tostdout = do
- h <- fdToHandle hin
- connect h stdout
- connect fromh toh = do
- hSetBinaryMode fromh True
- hSetBinaryMode toh True
- b <- B.hGetSome fromh 40960
- if B.null b
- then do
- hClose fromh
- hClose toh
- else do
- B.hPut toh b
- hFlush toh
- connect fromh toh
-
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
@@ -388,3 +345,56 @@ findLastNonSpinCommit = do
spinCommitMessage :: String
spinCommitMessage = "propellor spin"
+
+-- 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
+ 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"
+ unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
+ errorMessage "git merge from client failed"
+ where
+ fetchparams hin hout =
+ [ Param "fetch"
+ , Param "--progress"
+ , Param "--upload-pack"
+ , Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+ , Param "."
+ ]
+
+-- Shim for git push over the propellor ssh channel.
+-- Reads from stdin and sends it to hout;
+-- reads from hin and sends it to stdout.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+ where
+ fromstdin = do
+ h <- fdToHandle hout
+ stdin *>* h
+ tostdout = do
+ h <- fdToHandle hin
+ h *>* stdout
+
+-- Forward data from one handle to another.
+(*>*) :: Handle -> Handle -> IO ()
+fromh *>* toh = do
+ b <- B.hGetSome fromh 40960
+ if B.null b
+ then do
+ hClose fromh
+ hClose toh
+ else do
+ B.hPut toh b
+ hFlush toh
+ fromh *>* toh
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index 41f839f1..01d777a4 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -59,7 +59,7 @@ data DebianKernel = Linux | KFreeBSD | Hurd
deriving (Show, Eq)
-- | Debian has several rolling suites, and a number of stable releases,
--- such as Stable "jessie".
+-- such as Stable "stretch".
data DebianSuite = Experimental | Unstable | Testing | Stable Release
deriving (Show, Eq)