b0b76de · distributed-process

git.iko.soy/distributed-process

Run an arbitrary process closure on a VM

commitb0b76de298b6080772645eba9a0879d392aa3865 authorEdsko de Vries <edsko@well-typed.com> dateFri 3 Aug 2012, 08:43 (14 years ago) parent21dd5c1

4 files changed+55−24

compare with master

unifiedsplit

distributed-process-azure/distributed-process-azure.cabal+3−2 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+21−7 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+3−1 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/GenericMain.hs+28−14

distributed-process-azure/distributed-process-azure.cabal+3−2

@@ -26,11 +26,12 @@ Library

2626 libssh2 >= 0.2 && < 0.3,

2727 pureMD5 >= 2.1 && < 2.2,

2828 bytestring >= 0.9 && < 0.11,

29− distributed-process >= 0.2 && < 0.3,

29+ distributed-process >= 0.2.3 && < 0.3,

3030 binary >= 0.5 && < 0.6,

3131 network-transport-tcp >= 0.2 && < 0.3,

3232 optparse-applicative >= 0.2 && < 0.4,

33− transformers >= 0.3 && < 0.4

33+ transformers >= 0.3 && < 0.4,

34+ certificate == 1.2.3

3435 Exposed-modules: Control.Distributed.Process.Backend.Azure,

3536 Control.Distributed.Process.Backend.Azure.GenericMain

3637 Extensions: ViewPatterns,

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+21−7

@@ -5,6 +5,7 @@ module Control.Distributed.Process.Backend.Azure

55 , AzureParameters(..)

66 , defaultAzureParameters

77 , initializeBackend

8+ , remoteTable

89 -- * Re-exports from Azure Service Management

910 , CloudService(..)

1011 , VirtualMachine(..)

@@ -16,7 +17,7 @@ import System.Environment.Executable (getExecutablePath)

1617import System.Posix.Types (Fd)

1718import Data.Binary (encode, decode)

1819import Data.Digest.Pure.MD5 (md5, MD5Digest)

19−import qualified Data.ByteString.Lazy as BSL (readFile, putStr)

20+import qualified Data.ByteString.Lazy as BSL (ByteString, readFile, putStr, length, writeFile)

2021import Data.Typeable (Typeable)

2122import Control.Applicative ((<$>))

2223import Control.Monad (void)

@@ -61,15 +62,18 @@ import qualified Network.SSH.Client.LibSSH2.ByteString.Lazy as SSHBS

6162

6263-- CH

6364import Control.Distributed.Process

64− ( Closure

65+ ( Closure(Closure)

6566 , Process

6667 , Static

68+ , RemoteTable

6769 )

6870import Control.Distributed.Process.Closure

6971 ( remotable

70− , mkClosure

7172 , cpBind

7273 , SerializableDict(SerializableDict)

74+ , staticConst

75+ , staticApply

76+ , mkStatic

7377 )

7478import Control.Distributed.Process.Serializable (Serializable)

7579

@@ -79,7 +83,17 @@ encodeToStdout = liftIO . BSL.putStr . encode

7983encodeToStdoutDict :: SerializableDict a -> a -> Process ()

8084encodeToStdoutDict SerializableDict = encodeToStdout

8185

82−remotable ['encodeToStdout]

86+remotable ['encodeToStdoutDict]

87+

88+-- | Remote table necessary for the Azure backend

89+remoteTable :: RemoteTable -> RemoteTable

90+remoteTable = __remoteTable

91+

92+cpEncodeToStdout :: forall a. Typeable a => Static (SerializableDict a) -> Closure (a -> Process ())

93+cpEncodeToStdout dict = Closure decoder (encode ())

94+ where

95+ decoder :: Static (BSL.ByteString -> a -> Process ())

96+ decoder = staticConst `staticApply` ($(mkStatic 'encodeToStdoutDict) `staticApply` dict)

8397

8498-- | Azure backend

8599data Backend = Backend {

@@ -89,7 +103,7 @@ data Backend = Backend {

89103 , copyToVM :: VirtualMachine -> IO ()

90104 -- | Check the MD5 hash of the remote executable

91105 , checkMD5 :: VirtualMachine -> IO Bool

92− -- | @runOnVM vm port p bg@ starts a CH node on port 'port' and runs 'p'

106+ -- | @runOnVM dict vm port p@ starts a CH node on port 'port' and runs 'p'

93107 , callOnVM :: forall a. Serializable a => Static (SerializableDict a) -> VirtualMachine -> String -> Closure (Process a) -> IO a

94108 }

95109

@@ -158,13 +172,13 @@ apiCallOnVM params dict vm port proc =

158172 ++ " 2>&1"

159173 (_, r) <- SSH.withChannel (SSH.openChannelSession s) id fd s $ \ch -> do

160174 SSH.retryIfNeeded fd s $ SSH.channelExecute ch exe

161− SSHBS.writeChannel fd ch (encode proc)

175+ cnt <- SSHBS.writeChannel fd ch (encode proc')

162176 SSH.channelSendEOF ch

163177 SSHBS.readAllChannel fd ch

164178 return (decode r)

165179 where

166180 proc' :: Closure (Process ())

167− proc' = proc `cpBind` undefined

181+ proc' = proc `cpBind` cpEncodeToStdout dict

168182

169183-- | Check the MD5 hash of the executable on the remote machine

170184apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+3−1

@@ -9,7 +9,9 @@ import Control.Distributed.Process.Backend.Azure.GenericMain

99 )

1010

1111getPid :: () -> Process ProcessId

12−getPid () = getSelfPid

12+getPid () = do

13+ liftIO $ appendFile "Log" "getPid did run"

14+ getSelfPid

1315

1416remotable ['getPid]

1517

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/GenericMain.hs+28−14

@@ -13,23 +13,19 @@ import System.IO

1313 , hSetBinaryMode

1414 )

1515import Data.Binary (decode)

16−import qualified Data.ByteString.Lazy as BSL (ByteString, getContents)

16+import qualified Data.ByteString.Lazy as BSL (ByteString, getContents, length)

1717import Control.Monad (unless, forM, forM_, join)

18−import Control.Exception (throwIO)

19−import Control.Distributed.Process.Backend.Azure

20− ( AzureParameters(azureSshUserName)

21− , defaultAzureParameters

22− , initializeBackend

23− , cloudServices

24− , CloudService(cloudServiceName, cloudServiceVMs)

25− , VirtualMachine(vmName)

26− , Backend(copyToVM, checkMD5, callOnVM)

27− )

18+import Control.Exception (throwIO, SomeException)

19+import Control.Applicative ((<$>), (<*>), (<|>))

20+import Control.Monad.IO.Class (liftIO)

21+

22+-- SSH

2823import qualified Network.SSH.Client.LibSSH2.Foreign as SSH

2924 ( initialize

3025 , exit

3126 )

32−import Control.Applicative ((<$>), (<*>), (<|>))

27+

28+-- Command line options

3329import Options.Applicative

3430 ( Parser

3531 , strOption

@@ -47,17 +43,30 @@ import Options.Applicative

4743 , header

4844 , switch

4945 )

46+

47+-- CH

5048import Control.Distributed.Process

5149 ( RemoteTable

5250 , Closure

5351 , Process

5452 , unClosure

5553 , Static

54+ , catch

5655 )

5756import Control.Distributed.Process.Node (newLocalNode, runProcess, initRemoteTable)

5857import Control.Distributed.Process.Serializable (Serializable)

5958import Control.Distributed.Process.Closure (SerializableDict)

6059import Network.Transport.TCP (createTransport, defaultTCPParameters)

60+import Control.Distributed.Process.Backend.Azure

61+ ( AzureParameters(azureSshUserName)

62+ , defaultAzureParameters

63+ , initializeBackend

64+ , cloudServices

65+ , CloudService(cloudServiceName, cloudServiceVMs)

66+ , VirtualMachine(vmName)

67+ , Backend(copyToVM, checkMD5, callOnVM)

68+ )

69+import qualified Control.Distributed.Process.Backend.Azure as Azure (remoteTable)

6170

6271--------------------------------------------------------------------------------

6372-- Main --

@@ -112,7 +121,9 @@ genericMain remoteTable cmds = do

112121 ProcessPair rProc lProc dict ->

113122 callOnVM backend dict vm (remotePort cmd) rProc >>= lProc

114123 OnVmCommand (vmCmd@OnVmRun {}) -> do

115− onVmRun (remoteTable initRemoteTable) (onVmIP vmCmd) (onVmPort vmCmd)

124+ onVmRun (remoteTable . Azure.remoteTable $ initRemoteTable)

125+ (onVmIP vmCmd)

126+ (onVmPort vmCmd)

116127 SSH.exit

117128 where

118129 opts = info (helper <*> commandParser)

@@ -144,13 +155,16 @@ azureParameters opts (Just sshOpts) = do

144155onVmRun :: RemoteTable -> String -> String -> IO ()

145156onVmRun rtable host port = do

146157 hSetBinaryMode stdin True

158+ hSetBinaryMode stdout True

147159 proc <- BSL.getContents :: IO BSL.ByteString

148160 mTransport <- createTransport host port defaultTCPParameters

149161 case mTransport of

150162 Left err -> throwIO err

151163 Right transport -> do

152164 node <- newLocalNode transport rtable

153− runProcess node $ join . unClosure . decode $ proc

165+ runProcess node $

166+ catch (join . unClosure . decode $ proc)

167+ (\e -> liftIO (print (e :: SomeException) >> throwIO e))

154168

155169--------------------------------------------------------------------------------

156170-- Command line options --