@@ -7,16 +7,17 @@ module Control.Distributed.Process.Backend.Azure
77 -- * Re-exports from Azure Service Management
88 , CloudService(..)
99 , VirtualMachine(..)
10+ , Endpoint(..)
11+ , AzureSetup
1012 , Azure.cloudServices
1113 -- * Remote and local processes
1214 , ProcessPair(..)
1315 , RemoteProcess
1416 , LocalProcess
17+ , localSend
1518 , localExpect
1619 , remoteSend
1720 , remoteThrow
18− , remoteSend'
19− , localSend
2021 ) where
2122
2223import System.Environment (getEnv)
@@ -45,7 +46,7 @@ import Data.Typeable (Typeable)
4546import Control.Applicative ((<$>))
4647import Control.Monad (void, unless)
4748import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
48−import Control.Exception (Exception, catches, Handler(Handler))
49+import Control.Exception (Exception, catches, Handler(Handler), throwIO)
4950import Control.Monad.IO.Class (MonadIO, liftIO)
5051
5152-- Azure
@@ -101,20 +102,18 @@ data Backend = Backend {
101102 , copyToVM :: VirtualMachine -> IO ()
102103 -- | Check the MD5 hash of the remote executable
103104 , checkMD5 :: VirtualMachine -> IO Bool
104− -- | @runOnVM dict vm port p@ starts a CH node on port 'port' and runs 'p'
105− , callOnVM :: forall a.
106− VirtualMachine
107− -> String
108− -> ProcessPair a
109− -> IO a
110− -- | Create a new CH node and run the specified process in the background.
111− -- The CH node will exit when the process exists.
112− , spawnOnVM :: VirtualMachine
113− -> String
114− -> Closure (Backend -> Process ())
115− -> IO ()
105+ -- | @runOnVM vm port pp@ starts a new CH node on machine @vm@ and then
106+ -- runs the specified process pair. The CH node will shut down when the
107+ -- /local/ process exists. @callOnVM@ returns the returned by the local
108+ -- process on exit.
109+ , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
110+ -- | Create a new CH node and run the specified process.
111+ -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
112+ -- returns as soon as the process has been spawned.
113+ , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ()
116114 } deriving (Typeable)
117115
116+-- | Azure connection parameters
118117data AzureParameters = AzureParameters {
119118 azureSetup :: AzureSetup
120119 , azureSshUserName :: FilePath
@@ -270,19 +269,42 @@ localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
270269-- Local and remote processes --
271270--------------------------------------------------------------------------------
272271
272+-- | A process pair consists of a remote process and a local process. The local
273+-- process can send messages to the remote process using 'localSend' and wait
274+-- for messages from the remote process using 'localExpect'. The remote process
275+-- can send messages to the local process using 'remoteSend', and wait for
276+-- messages from the local process using the standard Cloud Haskell primitives.
277+--
278+-- See also 'callOnVM'.
273279data ProcessPair a = ProcessPair {
274280 ppairRemote :: RemoteProcess ()
275281 , ppairLocal :: LocalProcess a
276282 }
277283
284+-- | The process to run on the remote node (see 'ProcessPair' and 'callOnVM').
278285type RemoteProcess a = Closure (Backend -> Process a)
279286
287+-- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').
280288newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
281289 deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
282290
283291runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
284292runLocalProcess = runReaderT . unLocalProcess
285293
294+-- | Send a messages from the local process to the remote process
295+-- (see 'ProcessPair')
296+localSend :: Serializable a => a -> LocalProcess ()
297+localSend x = LocalProcess $ do
298+ ch <- ask
299+ liftIO $ mapM_ (SSH.writeChannel ch)
300+ . prependLength
301+ . messageToPayload
302+ . createMessage
303+ $ x
304+
305+-- | Wait for a message from the remote process (see 'ProcessPair').
306+-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
307+-- runtime error if the remote process sends a message of type other than @a@.
286308localExpect :: Serializable a => LocalProcess a
287309localExpect = LocalProcess $ do
288310 ch <- ask
@@ -294,20 +316,17 @@ localExpect = LocalProcess $ do
294316 then error (decode msg)
295317 else return (decode msg)
296318
297−localSend :: Serializable a => a -> LocalProcess ()
298−localSend x = LocalProcess $ do
299− ch <- ask
300− liftIO $ mapM_ (SSH.writeChannel ch)
301− . prependLength
302− . messageToPayload
303− . createMessage
304− $ x
305−
319+-- | Send a message from the remote process to the local process (see
320+-- 'ProcessPair'). Note that the remote process can use the standard Cloud
321+-- Haskell primitives to /receive/ messages from the local process.
306322remoteSend :: Serializable a => a -> Process ()
307323remoteSend = liftIO . remoteSend' 0
308324
309−remoteThrow :: Exception e => e -> Process ()
310−remoteThrow = liftIO . remoteSend' 1 . show
325+-- | If the remote process encounters an error it can use 'remoteThrow'. This
326+-- will cause the exception to be raised (as a user-exception, not as the
327+-- original type) in the local process (as well as in the remote process).
328+remoteThrow :: Exception e => e -> IO ()
329+remoteThrow e = remoteSend' 1 (show e) >> throwIO e
311330
312331remoteSend' :: Serializable a => Int -> a -> IO ()
313332remoteSend' flags x = do