remove simplsh debug code
Seems I have really fixed that bug!
This commit is contained in:
parent
ffce1f80ae
commit
5a5adab867
|
@ -354,12 +354,7 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
|
|||
<*> pure (simpleLogFormatter "[$time] $msg")
|
||||
updateGlobalLogger rootLoggerName $
|
||||
setLevel DEBUG . setHandlers [f]
|
||||
go _ = whenM ((==) "root" <$> myUserName) $ do
|
||||
f <- setFormatter
|
||||
<$> fileHandler "/usr/local/propellor/log" DEBUG
|
||||
<*> pure (simpleLogFormatter "[$time] $msg")
|
||||
updateGlobalLogger rootLoggerName $
|
||||
setLevel DEBUG . setHandlers [f]
|
||||
go _ = noop
|
||||
|
||||
-- Parameters can be passed to both ssh and scp, to enable a ssh connection
|
||||
-- caching socket.
|
||||
|
|
|
@ -335,29 +335,19 @@ provisionContainer cid = containerDesc cid $ property "provision" $ liftIO $ do
|
|||
|
||||
go lastline (v:rest) = case v of
|
||||
StdoutLine s -> do
|
||||
debug ["stdout: ", show s]
|
||||
maybe noop putStrLn lastline
|
||||
hFlush stdout
|
||||
go (Just s) rest
|
||||
StderrLine s -> do
|
||||
debug ["stderr: ", show s]
|
||||
maybe noop putStrLn lastline
|
||||
hFlush stdout
|
||||
hPutStrLn stderr s
|
||||
hFlush stderr
|
||||
go Nothing rest
|
||||
Done -> do
|
||||
debug ["reached Done"]
|
||||
ret lastline
|
||||
go lastline [] = do
|
||||
debug ["reached end of output"]
|
||||
ret lastline
|
||||
Done -> ret lastline
|
||||
go lastline [] = ret lastline
|
||||
|
||||
ret lastline = do
|
||||
let v = fromMaybe FailedChange $
|
||||
readish =<< lastline
|
||||
debug ["provisionContainer returning", show v]
|
||||
return v
|
||||
ret lastline = pure $ fromMaybe FailedChange $ readish =<< lastline
|
||||
|
||||
stopContainer :: ContainerId -> IO Bool
|
||||
stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ]
|
||||
|
|
|
@ -36,11 +36,9 @@ simpleSh namedpipe = do
|
|||
maybe noop (run h) . readish =<< hGetLine h
|
||||
where
|
||||
run h (Cmd cmd params) = do
|
||||
debug ["simplesh run", cmd, show params]
|
||||
chan <- newChan
|
||||
let runwriter = do
|
||||
v <- readChan chan
|
||||
debug ["simplesh run", cmd, show params, "writer got:", show v]
|
||||
hPutStrLn h (show v)
|
||||
hFlush h
|
||||
case v of
|
||||
|
@ -55,7 +53,6 @@ simpleSh namedpipe = do
|
|||
, std_err = CreatePipe
|
||||
}
|
||||
(Nothing, Just outh, Just errh, pid) <- createProcess p
|
||||
debug ["simplesh run", cmd, show params, "started"]
|
||||
|
||||
let mkreader t from = maybe noop (const $ mkreader t from)
|
||||
=<< catchMaybeIO (writeChan chan . t =<< hGetLine from)
|
||||
|
@ -63,33 +60,25 @@ simpleSh namedpipe = do
|
|||
(mkreader StdoutLine outh)
|
||||
(mkreader StderrLine errh)
|
||||
|
||||
debug ["simplesh run", cmd, show params, "waiting for process"]
|
||||
void $ tryIO $ waitForProcess pid
|
||||
|
||||
debug ["simplesh run", cmd, show params, "sending Done"]
|
||||
writeChan chan Done
|
||||
|
||||
hClose outh
|
||||
hClose errh
|
||||
|
||||
debug ["simplesh run", cmd, show params, "wait writer"]
|
||||
wait writer
|
||||
debug ["simplesh run", cmd, show params, "wait writer complete"]
|
||||
hClose h
|
||||
debug ["simplesh run", cmd, show params, "fully done"]
|
||||
|
||||
simpleShClient :: FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
|
||||
simpleShClient namedpipe cmd params handler = do
|
||||
debug ["simplesh connecting"]
|
||||
s <- socket AF_UNIX Stream defaultProtocol
|
||||
connect s (SockAddrUnix namedpipe)
|
||||
h <- socketToHandle s ReadWriteMode
|
||||
hPutStrLn h $ show $ Cmd cmd params
|
||||
hFlush h
|
||||
debug ["simplesh sent command"]
|
||||
resps <- catMaybes . map readish . lines <$> hGetContents h
|
||||
v <- hClose h `after` handler resps
|
||||
debug ["simplesh processed response"]
|
||||
return v
|
||||
|
||||
simpleShClientRetry :: Int -> FilePath -> String -> [String] -> ([Resp] -> IO a) -> IO a
|
||||
|
|
Loading…
Reference in New Issue