@@ -629,29 +629,7 @@ apiCallOnVM :: AzureParameters
629629 -> String
630630 -> ProcessPair a
631631 -> IO a
632−apiCallOnVM params cloudService vm port ppair =
633− withSSH2 params vm $ \s -> do
634− let exe = "PATH=. " ++ azureSshRemotePath params
635− ++ " onvm"
636− ++ " " ++ vmIpAddress vm
637− ++ " " ++ port
638− ++ " " ++ cloudService
639− ++ " False"
640− ++ " 2>&1"
641− let paramsEnc = encode params
642− (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
643− SSH.channelExecute ch exe
644− SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))
645− SSH.writeAllChannel ch rprocEnc
646− SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
647− SSH.writeAllChannel ch paramsEnc
648− runLocalProcess (ppairLocal ppair) ch
649− if status == 0
650− then return r
651− else error "callOnVM: Non-zero exit status"
652− where
653− rprocEnc :: BSL.ByteString
654− rprocEnc = encode (ppairRemote ppair)
632+apiCallOnVM = runOnVM False
655633
656634apiSpawnOnVM :: AzureParameters
657635 -> String
@@ -659,37 +637,40 @@ apiSpawnOnVM :: AzureParameters
659637 -> String
660638 -> Closure (Backend -> Process ())
661639 -> IO ProcessId
662−apiSpawnOnVM params cloudService vm port proc =
663− withSSH2 params vm $ \s -> do
664− -- TODO: reduce duplication with apiCallOnVM
665− let exe = "PATH=. " ++ azureSshRemotePath params
666− ++ " onvm"
667− ++ " " ++ vmIpAddress vm
668− ++ " " ++ port
669− ++ " " ++ cloudService
670− ++ " True"
671− ++ " 2>&1"
672− let paramsEnc = encode params
673− (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
674− SSH.channelExecute ch exe
675− SSH.writeChannel ch (encodeInt32 (BSL.length procEnc))
676− SSH.writeAllChannel ch procEnc
677− SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
678− SSH.writeAllChannel ch paramsEnc
679− localExpect' ch
680− if status == 0
681− then return r
682− else error "spawnOnVM: Non-zero exit status"
683− {-
684− --SSH.channelSendEOF ch
685− --SSH.readAllChannel ch
686− if status == 0
687− then return (decode r)
688− else error (BSLC.unpack r)
689− -}
690− where
691− procEnc :: BSL.ByteString
692− procEnc = encode proc
640+apiSpawnOnVM params cloudService vm port rproc =
641+ runOnVM True params cloudService vm port $
642+ ProcessPair rproc localExpect
643+
644+-- | Internal generalization of 'spawnOnVM' and 'callOnVM'
645+runOnVM :: Bool
646+ -> AzureParameters
647+ -> String
648+ -> VirtualMachine
649+ -> String
650+ -> ProcessPair a
651+ -> IO a
652+runOnVM bg params cloudService vm port ppair =
653+ withSSH2 params vm $ \s -> do
654+ -- TODO: reduce duplication with apiCallOnVM
655+ let exe = "PATH=. " ++ azureSshRemotePath params
656+ ++ " onvm"
657+ ++ " " ++ vmIpAddress vm
658+ ++ " " ++ port
659+ ++ " " ++ cloudService
660+ ++ " " ++ show bg
661+ ++ " 2>&1"
662+ let paramsEnc = encode params
663+ let rprocEnc = encode (ppairRemote ppair)
664+ (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
665+ SSH.channelExecute ch exe
666+ SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))
667+ SSH.writeAllChannel ch rprocEnc
668+ SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
669+ SSH.writeAllChannel ch paramsEnc
670+ runLocalProcess (ppairLocal ppair) ch
671+ if status == 0
672+ then return r
673+ else error "runOnVM: Non-zero exit status" -- This would a bug
693674
694675-- | Check the MD5 hash of the executable on the remote machine
695676apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
@@ -784,16 +765,15 @@ localSend x = LocalProcess $ do
784765-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
785766-- runtime error if the remote process sends a message of type other than @a@.
786767localExpect :: Serializable a => LocalProcess a
787−localExpect = LocalProcess $ ask >>= liftIO . localExpect'
788−
789−localExpect' :: Serializable a => SSH.Channel -> IO a
790−localExpect' ch = do
791− isE <- readIntChannel ch
792− len <- readIntChannel ch
793− msg <- readSizeChannel ch len
794− if isE /= 0
795− then error (decode msg)
796− else return (decode msg)
768+localExpect = LocalProcess $ do
769+ ch <- ask
770+ liftIO $ do
771+ isE <- readIntChannel ch
772+ len <- readIntChannel ch
773+ msg <- readSizeChannel ch len
774+ if isE /= 0
775+ then error (decode msg)
776+ else return (decode msg)
797777
798778-- | Send a message from the remote process to the local process (see
799779-- 'ProcessPair'). Note that the remote process can use the standard Cloud