@@ -413,7 +413,6 @@ module Control.Distributed.Process.Backend.Azure
413 , localSend
413 , localSend
414 , localExpect
414 , localExpect
415 , remoteSend
415 , remoteSend
419import Prelude hiding (catch)
418import Prelude hiding (catch)
@@ -451,7 +450,6 @@ import qualified Data.ByteString.Lazy as BSL
454−import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
455import Data.Typeable (Typeable)
453import Data.Typeable (Typeable)
456import Data.Foldable (forM_)
454import Data.Foldable (forM_)
457import Control.Applicative ((<$>), (<*>))
455import Control.Applicative ((<$>), (<*>))
@@ -678,11 +676,17 @@ apiSpawnOnVM params cloudService vm port proc =
678 SSH.writeAllChannel ch procEnc
676 SSH.writeAllChannel ch procEnc
679 SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
677 SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))
680 SSH.writeAllChannel ch paramsEnc
678 SSH.writeAllChannel ch paramsEnc
682+ else error "spawnOnVM: Non-zero exit status"
681− SSH.channelSendEOF ch
684+ --SSH.channelSendEOF ch
682− SSH.readAllChannel ch
685+ --SSH.readAllChannel ch
683 if status == 0
686 if status == 0
684 then return (decode r)
687 then return (decode r)
685 else error (BSLC.unpack r)
688 else error (BSLC.unpack r)
687 procEnc :: BSL.ByteString
691 procEnc :: BSL.ByteString
688 procEnc = encode proc
692 procEnc = encode proc
@@ -780,30 +784,34 @@ localSend x = LocalProcess $ do
780-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
784-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
781-- runtime error if the remote process sends a message of type other than @a@.
785-- runtime error if the remote process sends a message of type other than @a@.
782localExpect :: Serializable a => LocalProcess a
786localExpect :: Serializable a => LocalProcess a
783−localExpect = LocalProcess $ do
787+localExpect = LocalProcess $ ask >>= liftIO . localExpect'
785− liftIO $ do
789+localExpect' :: Serializable a => SSH.Channel -> IO a
786− isE <- readIntChannel ch
791+ isE <- readIntChannel ch
787− len <- readIntChannel ch
792+ len <- readIntChannel ch
788− msg <- readSizeChannel ch len
793+ msg <- readSizeChannel ch len
789− if isE /= 0
794+ if isE /= 0
790− then error (decode msg)
795+ then error (decode msg)
791− else return (decode msg)
796+ else return (decode msg)
793-- | Send a message from the remote process to the local process (see
798-- | Send a message from the remote process to the local process (see
794-- 'ProcessPair'). Note that the remote process can use the standard Cloud
799-- 'ProcessPair'). Note that the remote process can use the standard Cloud
795-- Haskell primitives to /receive/ messages from the local process.
800-- Haskell primitives to /receive/ messages from the local process.
796remoteSend :: Serializable a => a -> Process ()
801remoteSend :: Serializable a => a -> Process ()
797−remoteSend = liftIO . remoteSend' 0
802+remoteSend = liftIO . remoteSend'
804+remoteSend' :: Serializable a => a -> IO ()
805+remoteSend' = remoteSendFlagged 0
799-- | If the remote process encounters an error it can use 'remoteThrow'. This
807-- | If the remote process encounters an error it can use 'remoteThrow'. This
800-- will cause the exception to be raised (as a user-exception, not as the
808-- will cause the exception to be raised (as a user-exception, not as the
801-- original type) in the local process (as well as in the remote process).
809-- original type) in the local process (as well as in the remote process).
802remoteThrow :: Exception e => e -> IO ()
810remoteThrow :: Exception e => e -> IO ()
803−remoteThrow e = remoteSend' 1 (show e) >> throwIO e
811+remoteThrow e = remoteSendFlagged 1 (show e) >> throwIO e
805−remoteSend' :: Serializable a => Int -> a -> IO ()
813+remoteSendFlagged :: Serializable a => Int -> a -> IO ()
806−remoteSend' flags x = do
814+remoteSendFlagged flags x = do
807 let enc = encode x
815 let enc = encode x
808 BSS.hPut stdout (encodeInt32 flags)
816 BSS.hPut stdout (encodeInt32 flags)
809 BSS.hPut stdout (encodeInt32 (BSL.length enc))
817 BSS.hPut stdout (encodeInt32 (BSL.length enc))
@@ -841,12 +849,11 @@ onVmMain rtable [host, port, cloudService, bg] = do
841 (\node proc -> runProcess node $ do
849 (\node proc -> runProcess node $ do
842 us <- getSelfPid
850 us <- getSelfPid
843 liftIO $ do
851 liftIO $ do
844− BSL.hPut stdout (encode us)
852+ remoteSend' us
845 mapM_ hClose [stdin, stdout, stderr]
853 mapM_ hClose [stdin, stdout, stderr]
849− startCH rproc lprocMVar backend forkProcess (liftIO . remoteThrow)
856+ startCH rproc lprocMVar backend forkProcess
850 lproc <- readMVar lprocMVar
857 lproc <- readMVar lprocMVar
851 queueFromHandle stdin (CH.processQueue lproc)
858 queueFromHandle stdin (CH.processQueue lproc)
@@ -854,9 +861,8 @@ onVmMain rtable [host, port, cloudService, bg] = do
854 -> MVar CH.LocalProcess
861 -> MVar CH.LocalProcess
855 -> Backend
862 -> Backend
856 -> (CH.LocalNode -> Process () -> IO a)
863 -> (CH.LocalNode -> Process () -> IO a)
857− -> (SomeException -> Process ())
858 -> IO ()
864 -> IO ()
859− startCH rproc lprocMVar backend go exceptionHandler = do
865+ startCH rproc lprocMVar backend go = do
860 mTransport <- createTransport host port defaultTCPParameters
866 mTransport <- createTransport host port defaultTCPParameters
861 case mTransport of
867 case mTransport of
862 Left err -> remoteThrow err
868 Left err -> remoteThrow err
@@ -865,7 +871,8 @@ onVmMain rtable [host, port, cloudService, bg] = do
865 void . go node $ do
871 void . go node $ do
866 ask >>= liftIO . putMVar lprocMVar
872 ask >>= liftIO . putMVar lprocMVar
867 proc <- unClosure rproc :: Process (Backend -> Process ())
873 proc <- unClosure rproc :: Process (Backend -> Process ())
868− catch (proc backend) exceptionHandler
874+ catch (proc backend)
875+ (liftIO . (remoteThrow :: SomeException -> IO ()))
869onVmMain _ _
876onVmMain _ _
870 = error "Invalid arguments passed on onVmMain"
877 = error "Invalid arguments passed on onVmMain"