@@ -413,7 +413,6 @@ module Control.Distributed.Process.Backend.Azure
413413 , localSend
414414 , localExpect
415415 , remoteSend
416− , remoteThrow
417416 ) where
418417
419418import Prelude hiding (catch)
@@ -451,7 +450,6 @@ import qualified Data.ByteString.Lazy as BSL
451450 , hPut
452451 , hGet
453452 )
454−import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
455453import Data.Typeable (Typeable)
456454import Data.Foldable (forM_)
457455import Control.Applicative ((<$>), (<*>))
@@ -678,11 +676,17 @@ apiSpawnOnVM params cloudService vm port proc =
678676 SSH.writeAllChannel ch procEnc
679677 SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
680678 SSH.writeAllChannel ch paramsEnc
681− SSH.channelSendEOF ch
682− SSH.readAllChannel ch
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
683686 if status == 0
684687 then return (decode r)
685688 else error (BSLC.unpack r)
689+ -}
686690 where
687691 procEnc :: BSL.ByteString
688692 procEnc = encode proc
@@ -780,30 +784,34 @@ localSend x = LocalProcess $ do
780784-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
781785-- runtime error if the remote process sends a message of type other than @a@.
782786localExpect :: Serializable a => LocalProcess a
783−localExpect = LocalProcess $ do
784− ch <- ask
785− liftIO $ do
786− isE <- readIntChannel ch
787− len <- readIntChannel ch
788− msg <- readSizeChannel ch len
789− if isE /= 0
790− then error (decode msg)
791− else return (decode msg)
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)
792797
793798-- | Send a message from the remote process to the local process (see
794799-- 'ProcessPair'). Note that the remote process can use the standard Cloud
795800-- Haskell primitives to /receive/ messages from the local process.
796801remoteSend :: Serializable a => a -> Process ()
797−remoteSend = liftIO . remoteSend' 0
802+remoteSend = liftIO . remoteSend'
803+
804+remoteSend' :: Serializable a => a -> IO ()
805+remoteSend' = remoteSendFlagged 0
798806
799807-- | If the remote process encounters an error it can use 'remoteThrow'. This
800808-- will cause the exception to be raised (as a user-exception, not as the
801809-- original type) in the local process (as well as in the remote process).
802810remoteThrow :: Exception e => e -> IO ()
803−remoteThrow e = remoteSend' 1 (show e) >> throwIO e
811+remoteThrow e = remoteSendFlagged 1 (show e) >> throwIO e
804812
805−remoteSend' :: Serializable a => Int -> a -> IO ()
806−remoteSend' flags x = do
813+remoteSendFlagged :: Serializable a => Int -> a -> IO ()
814+remoteSendFlagged flags x = do
807815 let enc = encode x
808816 BSS.hPut stdout (encodeInt32 flags)
809817 BSS.hPut stdout (encodeInt32 (BSL.length enc))
@@ -841,12 +849,11 @@ onVmMain rtable [host, port, cloudService, bg] = do
841849 (\node proc -> runProcess node $ do
842850 us <- getSelfPid
843851 liftIO $ do
844− BSL.hPut stdout (encode us)
852+ remoteSend' us
845853 mapM_ hClose [stdin, stdout, stderr]
846854 proc)
847− (\_ -> return ())
848855 else do
849− startCH rproc lprocMVar backend forkProcess (liftIO . remoteThrow)
856+ startCH rproc lprocMVar backend forkProcess
850857 lproc <- readMVar lprocMVar
851858 queueFromHandle stdin (CH.processQueue lproc)
852859 where
@@ -854,9 +861,8 @@ onVmMain rtable [host, port, cloudService, bg] = do
854861 -> MVar CH.LocalProcess
855862 -> Backend
856863 -> (CH.LocalNode -> Process () -> IO a)
857− -> (SomeException -> Process ())
858864 -> IO ()
859− startCH rproc lprocMVar backend go exceptionHandler = do
865+ startCH rproc lprocMVar backend go = do
860866 mTransport <- createTransport host port defaultTCPParameters
861867 case mTransport of
862868 Left err -> remoteThrow err
@@ -865,7 +871,8 @@ onVmMain rtable [host, port, cloudService, bg] = do
865871 void . go node $ do
866872 ask >>= liftIO . putMVar lprocMVar
867873 proc <- unClosure rproc :: Process (Backend -> Process ())
868− catch (proc backend) exceptionHandler
874+ catch (proc backend)
875+ (liftIO . (remoteThrow :: SomeException -> IO ()))
869876onVmMain _ _
870877 = error "Invalid arguments passed on onVmMain"
871878