@@ -455,7 +455,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
455455import Data.Typeable (Typeable)
456456import Data.Foldable (forM_)
457457import Control.Applicative ((<$>), (<*>))
458−import Control.Monad (void, unless)
458+import Control.Monad (void)
459459import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
460460import Control.Exception
461461 ( Exception
@@ -510,6 +510,8 @@ import Control.Distributed.Process
510510 , RemoteTable
511511 , catch
512512 , unClosure
513+ , ProcessId
514+ , getSelfPid
513515 )
514516import Control.Distributed.Process.Serializable (Serializable)
515517import qualified Control.Distributed.Process.Internal.Types as CH
@@ -546,7 +548,7 @@ data Backend = Backend {
546548 -- | Create a new CH node and run the specified process.
547549 -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
548550 -- returns as soon as the process has been spawned.
549− , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ()
551+ , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId
550552 } deriving (Typeable)
551553
552554-- | Azure connection parameters
@@ -658,7 +660,7 @@ apiSpawnOnVM :: AzureParameters
658660 -> VirtualMachine
659661 -> String
660662 -> Closure (Backend -> Process ())
661− -> IO ()
663+ -> IO ProcessId
662664apiSpawnOnVM params cloudService vm port proc =
663665 withSSH2 params vm $ \s -> do
664666 -- TODO: reduce duplication with apiCallOnVM
@@ -678,7 +680,9 @@ apiSpawnOnVM params cloudService vm port proc =
678680 SSH.writeAllChannel ch paramsEnc
679681 SSH.channelSendEOF ch
680682 SSH.readAllChannel ch
681− unless (status == 0) $ error (BSLC.unpack r)
683+ if status == 0
684+ then return (decode r)
685+ else error (BSLC.unpack r)
682686 where
683687 procEnc :: BSL.ByteString
684688 procEnc = encode proc
@@ -822,15 +826,27 @@ onVmMain :: (RemoteTable -> RemoteTable) -> [String] -> IO ()
822826onVmMain rtable [host, port, cloudService, bg] = do
823827 hSetBinaryMode stdin True
824828 hSetBinaryMode stdout True
825− Just procEnc <- getWithLength stdin
829+ Just rprocEnc <- getWithLength stdin
826830 Just paramsEnc <- getWithLength stdin
827831 backend <- initializeBackend (decode paramsEnc) cloudService
828− let proc = decode procEnc
832+ let rproc = decode rprocEnc
829833 lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)
830834 if read bg
831− then detach $ startCH proc lprocMVar backend runProcess (\_ -> return ())
835+ then
836+ void . Posix.forkProcess $ do
837+ -- We inherit the file descriptors from the parent, so the SSH
838+ -- session will not be terminated until we close them
839+ void Posix.createSession
840+ startCH rproc lprocMVar backend
841+ (\node proc -> runProcess node $ do
842+ us <- getSelfPid
843+ liftIO $ do
844+ BSL.hPut stdout (encode us)
845+ mapM_ hClose [stdin, stdout, stderr]
846+ proc)
847+ (\_ -> return ())
832848 else do
833− startCH proc lprocMVar backend forkProcess (liftIO . remoteThrow)
849+ startCH rproc lprocMVar backend forkProcess (liftIO . remoteThrow)
834850 lproc <- readMVar lprocMVar
835851 queueFromHandle stdin (CH.processQueue lproc)
836852 where
@@ -875,11 +891,6 @@ queueFromHandle h q = do
875891 enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
876892 queueFromHandle h q
877893
878−detach :: IO () -> IO ()
879−detach io = do
880− mapM_ hClose [stdin, stdout, stderr]
881− void . Posix.forkProcess $ void Posix.createSession >> io
882−
883894--------------------------------------------------------------------------------
884895-- SSH utilities --
885896--------------------------------------------------------------------------------