propellor spin
This commit is contained in:
parent
435ba8ca41
commit
395f311e1e
|
@ -196,10 +196,10 @@ spin target relay hst = do
|
||||||
, "fi"
|
, "fi"
|
||||||
]
|
]
|
||||||
|
|
||||||
runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor " ++ cmd ]
|
runcmd = mkcmd [ "cd " ++ localdir ++ " && ./propellor --continue " ++ shellEscape (show cmd) ]
|
||||||
cmd = if isNothing relay
|
cmd = if isNothing relay
|
||||||
then "--continue " ++ shellEscape (show (SimpleRun target))
|
then SimpleRun target
|
||||||
else "--spin " ++ shellEscape target
|
else Spin target relay
|
||||||
runparams = catMaybes
|
runparams = catMaybes
|
||||||
[ if isJust relay then Just "-A" else Nothing
|
[ if isJust relay then Just "-A" else Nothing
|
||||||
, Just "-t"
|
, Just "-t"
|
||||||
|
|
|
@ -66,51 +66,54 @@ updateServer :: HostName -> Maybe HostName -> Host -> (((Handle, Handle) -> IO (
|
||||||
updateServer target relay hst connect = connect go
|
updateServer target relay hst connect = connect go
|
||||||
where
|
where
|
||||||
hn = fromMaybe target relay
|
hn = fromMaybe target relay
|
||||||
|
relaying = relay == Just target
|
||||||
|
|
||||||
go (toh, fromh) = do
|
go (toh, fromh) = do
|
||||||
let loop = go (toh, fromh)
|
let loop = go (toh, fromh)
|
||||||
|
let restart = updateServer hn relay hst connect
|
||||||
|
let done = return ()
|
||||||
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
|
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
|
||||||
case v of
|
case v of
|
||||||
(Just NeedRepoUrl) -> do
|
(Just NeedRepoUrl) -> do
|
||||||
sendRepoUrl toh
|
sendRepoUrl toh
|
||||||
loop
|
loop
|
||||||
(Just NeedPrivData) -> do
|
(Just NeedPrivData) -> do
|
||||||
sendPrivData hn hst toh relay
|
sendPrivData hn hst toh relaying
|
||||||
loop
|
loop
|
||||||
(Just NeedGitPush) -> do
|
|
||||||
sendGitUpdate hn fromh toh
|
|
||||||
-- no more protocol possible after git push
|
|
||||||
hClose fromh
|
|
||||||
hClose toh
|
|
||||||
(Just NeedGitClone) -> do
|
(Just NeedGitClone) -> do
|
||||||
hClose toh
|
hClose toh
|
||||||
hClose fromh
|
hClose fromh
|
||||||
sendGitClone hn
|
sendGitClone hn
|
||||||
updateServer hn relay hst connect
|
restart
|
||||||
(Just NeedPrecompiled) -> do
|
(Just NeedPrecompiled) -> do
|
||||||
hClose toh
|
hClose toh
|
||||||
hClose fromh
|
hClose fromh
|
||||||
sendPrecompiled hn
|
sendPrecompiled hn
|
||||||
updateServer hn relay hst connect
|
restart
|
||||||
Nothing -> return ()
|
(Just NeedGitPush) -> do
|
||||||
|
sendGitUpdate hn fromh toh
|
||||||
|
hClose fromh
|
||||||
|
hClose toh
|
||||||
|
done
|
||||||
|
Nothing -> done
|
||||||
|
|
||||||
sendRepoUrl :: Handle -> IO ()
|
sendRepoUrl :: Handle -> IO ()
|
||||||
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
|
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
|
||||||
|
|
||||||
sendPrivData :: HostName -> Host -> Handle -> Maybe HostName -> IO ()
|
sendPrivData :: HostName -> Host -> Handle -> Bool -> IO ()
|
||||||
sendPrivData hn hst toh target = do
|
sendPrivData hn hst toh relaying = do
|
||||||
privdata <- getdata
|
privdata <- getdata
|
||||||
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
|
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
|
||||||
sendMarked toh privDataMarker privdata
|
sendMarked toh privDataMarker privdata
|
||||||
return True
|
return True
|
||||||
where
|
where
|
||||||
getdata
|
getdata
|
||||||
| isNothing target =
|
| relaying = do
|
||||||
show . filterPrivData hst <$> decryptPrivData
|
|
||||||
| otherwise = do
|
|
||||||
let f = privDataRelay hn
|
let f = privDataRelay hn
|
||||||
d <- readFileStrictAnyEncoding f
|
d <- readFileStrictAnyEncoding f
|
||||||
nukeFile f
|
nukeFile f
|
||||||
return d
|
return d
|
||||||
|
| otherwise = show . filterPrivData hst <$> decryptPrivData
|
||||||
|
|
||||||
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
|
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
|
||||||
sendGitUpdate hn fromh toh =
|
sendGitUpdate hn fromh toh =
|
||||||
|
|
Loading…
Reference in New Issue