@@ -103,13 +103,13 @@
104-- > cabal-dev install distributed-process-azure -f build-demos
104-- > cabal-dev install distributed-process-azure -f build-demos
106−-- We can use any of the demos to test our setup; we will use the @ping@ demo:
106+-- We can the @cloud-haskell-azure-ping@ demo to test our setup:
108-- > cloud-haskell-azure-ping list \
108-- > cloud-haskell-azure-ping list \
109−-- > --subscription-id <<your subscription ID>> \
109+-- > <<your subscription ID>> \
110−-- > --certificate /path/to/credentials.x509 \
110+-- > /path/to/credentials.x509 \
111−-- > --private /path/to/credentials.private
111+-- > /path/to/credentials.private
113-- (you can find your subscription ID in the @.publishsettings@ file from the previous step).
113-- (you can find your subscription ID in the @.publishsettings@ file from the previous step).
114-- If everything went well, this will output something like
114-- If everything went well, this will output something like
@@ -182,63 +182,35 @@
182-- machine will echo this back; the local machine will wait for the echo, show
182-- machine will echo this back; the local machine will wait for the echo, show
183-- the echo, and repeat.
183-- the echo, and repeat.
185−-- Before you can try it you will first need to copy the executable to the remote server:
185+-- Before you can try it you will first need to copy the executable (for
186−--
186+-- example, using scp, although the Azure backend also provides this natively
187−-- > cloud-haskell-azure-echo install \
188−-- > --subscription-id <<your subscription ID>> \
189−-- > --certificate /path/to/credentials.x509 \
190−-- > --private /path/to/credentials.private \
191−-- > --user <<remote username>> \
192−-- > --cloud-service <<Cloud Service name>> \
193−-- > --virtual-machine <<Virtual Machine name>>
195−-- (If you leave out the @--virtual-machine@ argument the binary will be copied
196−-- to every virtual machine in the specified cloud service). Once installed,
197−-- you can run it as follows:
187+-- in Haskell). Once that's done, you can run the demo as follows:
199−-- > cloud-haskell-azure-echo run \
189+-- > cloud-haskell-azure-echo \
200−-- > --subscription-id <<your subscription ID>> \
190+-- > <<subscription ID>> \
201−-- > --certificate /path/to/credentials.x509 \
191+-- > /path/to/credentials.x509 \
202−-- > --private /path/to/credentials.private \
192+-- > /path/to/credentials.private \
203−-- > --user <<remote username>> \
193+-- > <<remote username>> \
204−-- > --cloud-service <<Cloud Service name>> \
194+-- > <<cloud service name>> \
205−-- > --virtual-machine <<Virtual Machine name>> \
195+-- > <<virtual machine name>> \
206−-- > --port 8080 \
196+-- > <<port number>>
208−-- > CHDemo1: # Everything I type will be echoed back
197+-- > # Everything I type gets echoed back
209−-- > Echo: Everything I type will be echoed back
198+-- > Echo: Everything I type gets echoed back
210-- > # Until I enter a blank line
199-- > # Until I enter a blank line
211-- > Echo: Until I enter a blank line
200-- > Echo: Until I enter a blank line
214−-- "Control.Distributed.Process.Backend.Azure.GenericMain" provides a generic
215−-- main function that you can use to structure your code. It provides command line
216−-- arguments such as the ones we saw in section /Testing the Setup/, it
217−-- initializes the Azure backend, and it takes care of running your code on the
218−-- remote machines. You don't have to use 'genericMain' if you prefer not to,
219−-- but then it will be your own responsibility to initialize Azure and to make
220−-- sure that your executable does the right thing when it's invoked on the
221−-- remote node. In these notes we will assume that you will use 'genericMain'.
223-- The full @echo@ demo is
203-- The full @echo@ demo is
225-- > {-# LANGUAGE TemplateHaskell #-}
205-- > {-# LANGUAGE TemplateHaskell #-}
227-- > import System.IO (hFlush, stdout)
207-- > import System.IO (hFlush, stdout)
208+-- > import System.Environment (getArgs)
228-- > import Control.Monad (unless, forever)
209-- > import Control.Monad (unless, forever)
229-- > import Control.Monad.IO.Class (liftIO)
210-- > import Control.Monad.IO.Class (liftIO)
230-- > import Control.Distributed.Process (Process, expect)
211-- > import Control.Distributed.Process (Process, expect)
231-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
212-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
232-- > import Control.Distributed.Process.Backend.Azure
213-- > import Control.Distributed.Process.Backend.Azure
234−-- > , ProcessPair(..)
241−-- > import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)
243-- > echoRemote :: () -> Backend -> Process ()
215-- > echoRemote :: () -> Backend -> Process ()
244-- > echoRemote () _backend = forever $ do
216-- > echoRemote () _backend = forever $ do
@@ -258,84 +230,61 @@
258-- > echoLocal
230-- > echoLocal
260-- > main :: IO ()
232-- > main :: IO ()
261−-- > main = genericMain __remoteTable callable spawnable
233+-- > main = do
262−-- > where
234+-- > args <- getArgs
263−-- > callable :: String -> IO (ProcessPair ())
235+-- > case args of
236+-- > "onvm":args' -> onVmMain __remoteTable args'
237+-- > sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
238+-- > params <- defaultAzureParameters sid x509 pkey
239+-- > let params' = params { azureSshUserName = user }
240+-- > backend <- initializeBackend params' cloudService
241+-- > Just vm <- findNamedVM backend virtualMachine
242+-- > callOnVM backend vm port $
264−-- > callable "echo" = return $ ProcessPair ($(mkClosure 'echoRemote) ()) echoLocal
243+-- > ProcessPair ($(mkClosure 'echoRemote) ())
265−-- > callable _ = error "callable: unknown"
244+-- > echoLocal
267−-- > spawnable :: String -> IO (RemoteProcess ())
268−-- > spawnable _ = error "spawnable: unknown"
270−-- 'genericMain' expects three arguments: the first is the standard
271−-- '__remoteTable' argument familiar from
272−-- "Control.Distributed.Process.Closure"; the second and third should map
273−-- strings to process pairs (for use with 'callOnVM') or remote processes (for
274−-- use with 'spawnOnVM') respectively.
276−-- When you invoke the @echo@ demo with @--closure echo@ the 'genericMain'
277−-- function calls 'callOnVM' with the process pair consisting of 'echoRemote'
278−-- and 'echoLocal'. Hopefully the definition of these two functions is
281-- [Second Example: Ping]
246-- [Second Example: Ping]
283-- The second example differs from the @echo@ demo in that it uses both
248-- The second example differs from the @echo@ demo in that it uses both
284−-- 'callable' ('callOnVM') and 'spawnable' ('spawnOnVM'). It uses the latter to
249+-- 'callOnVM' and 'spawnOnVM'. It uses the latter to
285-- install a ping server which keeps running in the background; it uses the
250-- install a ping server which keeps running in the background; it uses the
286-- former to run a ping client which sends a request to the ping server and
251-- former to run a ping client which sends a request to the ping server and
287−-- outputs the response. As with the @echo@ server, we must first copy the
252+-- outputs the response.
288−-- executable:
253+--
289−--
254+-- As with the @echo@ demo, make sure to copy the executable to the remote server first.
290−-- > cloud-haskell-azure-ping install \
255+-- Once that is done, you can start a ping server on a virtual machine using
291−-- > --subscription-id <<your subscription ID>> \
292−-- > --certificate /path/to/credentials.x509 \
293−-- > --private /path/to/credentials.private \
294−-- > --user <<remote username>> \
295−-- > --cloud-service <<Cloud Service name>> \
300−-- Now we can start the ping server on every virtual machine in the cloud
301−-- service (to install it to a single virtual machine only, pass the
302−-- @--virtual-machine@ argument):
304−-- > cloud-haskell-azure-ping run \
257+-- > cloud-haskell-azure-ping server \
305−-- > --subscription-id <<your subscription ID>> \
258+-- > <<subscription ID>> \
306−-- > --certificate /path/to/credentials.x509 \
259+-- > /path/to/credentials.x509 \
307−-- > --private /path/to/credentials.private \
260+-- > /path/to/credentials.private \
308−-- > --user <<remote username>> \
261+-- > <<remote username>> \
309−-- > --cloud-service <<Cloud Service name>> \
262+-- > <<cloud service name>> \
263+-- > <<virtual machine name>> \
310−-- > --port 8080
264+-- > <<port number>>
311−-- > --closure server
317-- Finally, we can run the ping client:
266-- Finally, we can run the ping client:
319−-- > cloud-haskell-azure-ping run
268+-- > cloud-haskell-azure-ping client \
320−-- > --subscription-id <<your subscription ID>> \
269+-- > <<subscription ID>> \
321−-- > --certificate /path/to/credentials.x509 \
270+-- > /path/to/credentials.x509 \
322−-- > --private /path/to/credentials.private \
271+-- > /path/to/credentials.private \
323−-- > --user <<remote username>> \
272+-- > <<remote username>> \
324−-- > --cloud-service <<Cloud Service name>> \
273+-- > <<cloud service name>> \
325−-- > --port 8081
274+-- > <<virtual machine name>> \
326−-- > --closure client
275+-- > <<DIFFERENT port number>>
327−-- > CHDemo3: Ping server at pid://10.119.182.127:8080:0:2 ok
328−-- > CHDemo2: Ping server at pid://10.59.238.125:8080:0:2 ok
329−-- > CHDemo1: Ping server at pid://10.59.224.122:8080:0:2 ok
276+-- > Ping server at pid://10.59.224.122:8080:0:2 ok
331-- Note that we must pass a different port number, because the client will run
278-- Note that we must pass a different port number, because the client will run
332-- within its own Cloud Haskell instance.
279-- within its own Cloud Haskell instance.
334−-- The code for the ping demo is similar to the echo demo, but demonstrates
281+-- The code for the @ping@ demo is similar to the @echo@ demo, but uses both
335−-- both 'callable' and 'spawnable' and shows one way to discover nodes.
282+-- 'callOnVM' and 'spawnOnVM' and demonstrates a way to discover processes (in
283+-- this case, through a PID file).
337-- > {-# LANGUAGE TemplateHaskell #-}
285-- > {-# LANGUAGE TemplateHaskell #-}
287+-- > import System.Environment (getArgs)
339-- > import Data.Binary (encode, decode)
288-- > import Data.Binary (encode, decode)
340-- > import Control.Monad (forever)
289-- > import Control.Monad (forever)
341-- > import Control.Monad.IO.Class (liftIO)
290-- > import Control.Monad.IO.Class (liftIO)
@@ -352,14 +301,6 @@
353-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
302-- > import Control.Distributed.Process.Closure (remotable, mkClosure)
354-- > import Control.Distributed.Process.Backend.Azure
303-- > import Control.Distributed.Process.Backend.Azure
356−-- > , ProcessPair(..)
362−-- > import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)
363-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
304-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
365-- > pingServer :: () -> Backend -> Process ()
306-- > pingServer :: () -> Backend -> Process ()
@@ -395,28 +336,34 @@
395-- > pingClientLocal = localExpect >>= liftIO . putStrLn
336-- > pingClientLocal = localExpect >>= liftIO . putStrLn
397-- > main :: IO ()
338-- > main :: IO ()
398−-- > main = genericMain __remoteTable callable spawnable
339+-- > main = do
399−-- > where
340+-- > args <- getArgs
400−-- > callable :: String -> IO (ProcessPair ())
341+-- > case args of
342+-- > "onvm":args' -> onVmMain __remoteTable args'
343+-- > "list":sid:x509:pkey:_ -> do
344+-- > params <- defaultAzureParameters sid x509 pkey
345+-- > css <- cloudServices (azureSetup params)
347+-- > cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do
348+-- > params <- defaultAzureParameters sid x509 pkey
349+-- > let params' = params { azureSshUserName = user }
350+-- > backend <- initializeBackend params' cloudService
351+-- > Just vm <- findNamedVM backend virtualMachine
353+-- > "server" -> spawnOnVM backend vm port ($(mkClosure 'pingServer) ())
354+-- > "client" -> callOnVM backend vm port $
401−-- > callable "client" = return $ ProcessPair ($(mkClosure 'pingClientRemote) ()) pingClientLocal
355+-- > ProcessPair ($(mkClosure 'pingClientRemote) ())
402−-- > callable _ = error "callable: unknown"
356+-- > pingClientLocal
404−-- > spawnable :: String -> IO (RemoteProcess ())
405−-- > spawnable "server" = return $ ($(mkClosure 'pingServer) ())
406−-- > spawnable _ = error "spawnable: unknown"
408−-- The ping server stores its PID in a file, which the ping client attempts to
409−-- read. This kind of pattern is typical, and is provided for in the high-level API.
411−-- [Using the High-Level API]
413−-- TODO: Does not yet exist.
414module Control.Distributed.Process.Backend.Azure
357module Control.Distributed.Process.Backend.Azure
415 ( -- * Initialization
358 ( -- * Initialization
416 Backend(..)
359 Backend(..)
417 , AzureParameters(..)
360 , AzureParameters(..)
418 , defaultAzureParameters
361 , defaultAzureParameters
419 , initializeBackend
362 , initializeBackend
420 -- * Re-exports from Azure Service Management
367 -- * Re-exports from Azure Service Management
421 , CloudService(..)
368 , CloudService(..)
422 , VirtualMachine(..)
369 , VirtualMachine(..)
@@ -433,10 +380,22 @@ module Control.Distributed.Process.Backend.Azure
433 , remoteThrow
380 , remoteThrow
383+import Prelude hiding (catch)
436import System.Environment (getEnv)
384import System.Environment (getEnv)
437import System.FilePath ((</>), takeFileName)
385import System.FilePath ((</>), takeFileName)
438import System.Environment.Executable (getExecutablePath)
386import System.Environment.Executable (getExecutablePath)
439−import System.IO (stdout, hFlush)
387+import System.IO
397+import qualified System.Posix.Process as Posix (forkProcess, createSession)
398+import Data.Maybe (listToMaybe)
440import Data.Binary (Binary(get, put), encode, decode)
399import Data.Binary (Binary(get, put), encode, decode)
441import Data.Digest.Pure.MD5 (md5, MD5Digest)
400import Data.Digest.Pure.MD5 (md5, MD5Digest)
442import qualified Data.ByteString as BSS
401import qualified Data.ByteString as BSS
@@ -444,6 +403,7 @@ import qualified Data.ByteString as BSS
448import qualified Data.ByteString.Char8 as BSSC (pack)
408import qualified Data.ByteString.Char8 as BSSC (pack)
449import qualified Data.ByteString.Lazy as BSL
409import qualified Data.ByteString.Lazy as BSL
@@ -453,14 +413,23 @@ import qualified Data.ByteString.Lazy as BSL
453 , fromChunks
413 , fromChunks
454 , toChunks
414 , toChunks
457import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
418import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
458import Data.Typeable (Typeable)
419import Data.Typeable (Typeable)
420+import Data.Foldable (forM_)
459import Control.Applicative ((<$>), (<*>))
421import Control.Applicative ((<$>), (<*>))
460import Control.Monad (void, unless)
422import Control.Monad (void, unless)
461import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
423import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
462−import Control.Exception (Exception, catches, Handler(Handler), throwIO)
424+import Control.Exception
463import Control.Monad.IO.Class (MonadIO, liftIO)
431import Control.Monad.IO.Class (MonadIO, liftIO)
432+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)
466import Network.Azure.ServiceManagement
435import Network.Azure.ServiceManagement
@@ -499,12 +468,30 @@ import qualified Network.SSH.Client.LibSSH2.Errors as SSH
502−import Control.Distributed.Process (Process, Closure)
471+import Control.Distributed.Process
503import Control.Distributed.Process.Serializable (Serializable)
478import Control.Distributed.Process.Serializable (Serializable)
504−import Control.Distributed.Process.Internal.Types
479+import qualified Control.Distributed.Process.Internal.Types as CH
481+ , LocalProcess(processQueue)
505− ( messageToPayload
484+ , messageToPayload
506 , createMessage
485 , createMessage
487+import Control.Distributed.Process.Node
493+import Control.Distributed.Process.Internal.CQueue (CQueue, enqueue)
494+import Network.Transport.TCP (createTransport, defaultTCPParameters)
508import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)
495import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)
510-- | Azure backend
497-- | Azure backend
@@ -609,10 +596,11 @@ apiCallOnVM :: AzureParameters
609apiCallOnVM params cloudService vm port ppair =
596apiCallOnVM params cloudService vm port ppair =
610 withSSH2 params vm $ \s -> do
597 withSSH2 params vm $ \s -> do
611 let exe = "PATH=. " ++ azureSshRemotePath params
598 let exe = "PATH=. " ++ azureSshRemotePath params
612− ++ " onvm run "
599+ ++ " onvm"
613− ++ " --host " ++ vmIpAddress vm
600+ ++ " " ++ vmIpAddress vm
614− ++ " --port " ++ port
601+ ++ " " ++ port
615− ++ " --cloud-service " ++ cloudService
602+ ++ " " ++ cloudService
616 ++ " 2>&1"
604 ++ " 2>&1"
617 let paramsEnc = encode params
605 let paramsEnc = encode params
618 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
606 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
@@ -639,11 +627,11 @@ apiSpawnOnVM params cloudService vm port proc =
639 withSSH2 params vm $ \s -> do
627 withSSH2 params vm $ \s -> do
640 -- TODO: reduce duplication with apiCallOnVM
628 -- TODO: reduce duplication with apiCallOnVM
641 let exe = "PATH=. " ++ azureSshRemotePath params
629 let exe = "PATH=. " ++ azureSshRemotePath params
642− ++ " onvm run "
630+ ++ " onvm"
643− ++ " --host " ++ vmIpAddress vm
631+ ++ " " ++ vmIpAddress vm
644− ++ " --port " ++ port
632+ ++ " " ++ port
645− ++ " --cloud-service " ++ cloudService
633+ ++ " " ++ cloudService
646− ++ " --background "
634+ ++ " True"
647 ++ " 2>&1"
635 ++ " 2>&1"
648 let paramsEnc = encode params
636 let paramsEnc = encode params
649 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
637 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
@@ -702,6 +690,15 @@ catchSshError s io =
702localHash :: AzureParameters -> IO MD5Digest
690localHash :: AzureParameters -> IO MD5Digest
703localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
691localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
693+--------------------------------------------------------------------------------
695+--------------------------------------------------------------------------------
697+-- | Find a virtual machine with a particular name
698+findNamedVM :: Backend -> String -> IO (Maybe VirtualMachine)
699+findNamedVM backend vm =
700+ listToMaybe . filter ((== vm) . vmName) <$> findVMs backend
705--------------------------------------------------------------------------------
702--------------------------------------------------------------------------------
706-- Local and remote processes --
703-- Local and remote processes --
707--------------------------------------------------------------------------------
704--------------------------------------------------------------------------------
@@ -735,8 +732,8 @@ localSend x = LocalProcess $ do
735 ch <- ask
732 ch <- ask
736 liftIO $ mapM_ (SSH.writeChannel ch)
733 liftIO $ mapM_ (SSH.writeChannel ch)
737 . prependLength
734 . prependLength
738− . messageToPayload
735+ . CH.messageToPayload
739− . createMessage
736+ . CH.createMessage
742-- | Wait for a message from the remote process (see 'ProcessPair').
739-- | Wait for a message from the remote process (see 'ProcessPair').
@@ -773,6 +770,80 @@ remoteSend' flags x = do
773 BSL.hPut stdout enc
770 BSL.hPut stdout enc
774 hFlush stdout
771 hFlush stdout
773+--------------------------------------------------------------------------------
775+--------------------------------------------------------------------------------
777+-- | Program main when run on the VM. A typical 'main' function looks like
783+-- > "onvm":args' -> onVmMain __remoteTable args'
784+-- > _ -> -- your normal main
785+onVmMain :: (RemoteTable -> RemoteTable) -> [String] -> IO ()
786+onVmMain rtable [host, port, cloudService, bg] = do
787+ hSetBinaryMode stdin True
788+ hSetBinaryMode stdout True
789+ Just procEnc <- getWithLength stdin
790+ Just paramsEnc <- getWithLength stdin
791+ backend <- initializeBackend (decode paramsEnc) cloudService
792+ let proc = decode procEnc
793+ lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)
795+ then detach $ startCH proc lprocMVar backend runProcess (\_ -> return ())
797+ startCH proc lprocMVar backend forkProcess (liftIO . remoteThrow)
798+ lproc <- readMVar lprocMVar
799+ queueFromHandle stdin (CH.processQueue lproc)
801+ startCH :: RemoteProcess ()
802+ -> MVar CH.LocalProcess
804+ -> (CH.LocalNode -> Process () -> IO a)
805+ -> (SomeException -> Process ())
807+ startCH rproc lprocMVar backend go exceptionHandler = do
808+ mTransport <- createTransport host port defaultTCPParameters
810+ Left err -> remoteThrow err
811+ Right transport -> do
812+ node <- newLocalNode transport (rtable initRemoteTable)
814+ ask >>= liftIO . putMVar lprocMVar
815+ proc <- unClosure rproc :: Process (Backend -> Process ())
816+ catch (proc backend) exceptionHandler
818+ = error "Invalid arguments passed on onVmMain"
820+-- | Read a 4-byte length @l@ and then an @l@-byte payload
822+-- Returns Nothing on EOF
823+getWithLength :: Handle -> IO (Maybe BSL.ByteString)
825+ lenEnc <- BSS.hGet h 4
826+ if BSS.length lenEnc < 4
829+ let len = decodeInt32 lenEnc
830+ bs <- BSL.hGet h len
831+ if BSL.length bs < fromIntegral len
833+ else return (Just bs)
835+queueFromHandle :: Handle -> CQueue CH.Message -> IO ()
836+queueFromHandle h q = do
837+ mPayload <- getWithLength stdin
838+ forM_ mPayload $ \payload -> do
839+ enqueue q $ CH.payloadToMessage (BSL.toChunks payload)
842+detach :: IO () -> IO ()
844+ mapM_ hClose [stdin, stdout, stderr]
845+ void . Posix.forkProcess $ void Posix.createSession >> io
776--------------------------------------------------------------------------------
847--------------------------------------------------------------------------------
777-- SSH utilities --
848-- SSH utilities --
778--------------------------------------------------------------------------------
849--------------------------------------------------------------------------------