@@ -7,16 +7,17 @@ module Control.Distributed.Process.Backend.Azure
7 -- * Re-exports from Azure Service Management
7 -- * Re-exports from Azure Service Management
8 , CloudService(..)
8 , CloudService(..)
9 , VirtualMachine(..)
9 , VirtualMachine(..)
10 , Azure.cloudServices
12 , Azure.cloudServices
11 -- * Remote and local processes
13 -- * Remote and local processes
12 , ProcessPair(..)
14 , ProcessPair(..)
13 , RemoteProcess
15 , RemoteProcess
14 , LocalProcess
16 , LocalProcess
15 , localExpect
18 , localExpect
16 , remoteSend
19 , remoteSend
17 , remoteThrow
20 , remoteThrow
22import System.Environment (getEnv)
23import System.Environment (getEnv)
@@ -45,7 +46,7 @@ import Data.Typeable (Typeable)
45import Control.Applicative ((<$>))
46import Control.Applicative ((<$>))
46import Control.Monad (void, unless)
47import Control.Monad (void, unless)
47import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
48import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
48−import Control.Exception (Exception, catches, Handler(Handler))
49+import Control.Exception (Exception, catches, Handler(Handler), throwIO)
49import Control.Monad.IO.Class (MonadIO, liftIO)
50import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -101,20 +102,18 @@ data Backend = Backend {
101 , copyToVM :: VirtualMachine -> IO ()
102 , copyToVM :: VirtualMachine -> IO ()
102 -- | Check the MD5 hash of the remote executable
103 -- | Check the MD5 hash of the remote executable
103 , checkMD5 :: VirtualMachine -> IO Bool
104 , checkMD5 :: VirtualMachine -> IO Bool
104− -- | @runOnVM dict vm port p@ starts a CH node on port 'port' and runs 'p'
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
105− , callOnVM :: forall a.
109+ , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a
110− -- | Create a new CH node and run the specified process in the background.
110+ -- | Create a new CH node and run the specified process.
111− -- The CH node will exit when the process exists.
111+ -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@
112+ -- returns as soon as the process has been spawned.
112− , spawnOnVM :: VirtualMachine
113+ , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ()
114− -> Closure (Backend -> Process ())
116 } deriving (Typeable)
114 } deriving (Typeable)
116+-- | Azure connection parameters
118data AzureParameters = AzureParameters {
117data AzureParameters = AzureParameters {
119 azureSetup :: AzureSetup
118 azureSetup :: AzureSetup
120 , azureSshUserName :: FilePath
119 , azureSshUserName :: FilePath
@@ -270,19 +269,42 @@ localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
270-- Local and remote processes --
269-- Local and remote processes --
271--------------------------------------------------------------------------------
270--------------------------------------------------------------------------------
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.
278+-- See also 'callOnVM'.
273data ProcessPair a = ProcessPair {
279data ProcessPair a = ProcessPair {
274 ppairRemote :: RemoteProcess ()
280 ppairRemote :: RemoteProcess ()
275 , ppairLocal :: LocalProcess a
281 , ppairLocal :: LocalProcess a
284+-- | The process to run on the remote node (see 'ProcessPair' and 'callOnVM').
278type RemoteProcess a = Closure (Backend -> Process a)
285type RemoteProcess a = Closure (Backend -> Process a)
287+-- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').
280newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
288newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }
281 deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
289 deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)
283runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
291runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a
284runLocalProcess = runReaderT . unLocalProcess
292runLocalProcess = runReaderT . unLocalProcess
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
299+ liftIO $ mapM_ (SSH.writeChannel ch)
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@.
286localExpect :: Serializable a => LocalProcess a
308localExpect :: Serializable a => LocalProcess a
287localExpect = LocalProcess $ do
309localExpect = LocalProcess $ do
288 ch <- ask
310 ch <- ask
@@ -294,20 +316,17 @@ localExpect = LocalProcess $ do
294 then error (decode msg)
316 then error (decode msg)
295 else return (decode msg)
317 else return (decode msg)
297−localSend :: Serializable a => a -> LocalProcess ()
319+-- | Send a message from the remote process to the local process (see
298−localSend x = LocalProcess $ do
320+-- 'ProcessPair'). Note that the remote process can use the standard Cloud
299− ch <- ask
321+-- Haskell primitives to /receive/ messages from the local process.
300− liftIO $ mapM_ (SSH.writeChannel ch)
306remoteSend :: Serializable a => a -> Process ()
322remoteSend :: Serializable a => a -> Process ()
307remoteSend = liftIO . remoteSend' 0
323remoteSend = liftIO . remoteSend' 0
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).
309−remoteThrow :: Exception e => e -> Process ()
328+remoteThrow :: Exception e => e -> IO ()
310−remoteThrow = liftIO . remoteSend' 1 . show
329+remoteThrow e = remoteSend' 1 (show e) >> throwIO e
312remoteSend' :: Serializable a => Int -> a -> IO ()
331remoteSend' :: Serializable a => Int -> a -> IO ()
313remoteSend' flags x = do
332remoteSend' flags x = do