13ac8e7 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Actually, Static constructor should not be exposed

13ac8e7Edsko de Vries14 years ago

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

compare with master

unifiedsplit

@@ -29,10 +29,14 @@ Library

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

30 binary >= 0.5 && < 0.6,

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

32− optparse-applicative >= 0.2 && < 0.4

32+ optparse-applicative >= 0.2 && < 0.4,

33+ transformers >= 0.3 && < 0.4

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

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

34 Control.Distributed.Process.Backend.Azure.GenericMain

35 Control.Distributed.Process.Backend.Azure.GenericMain

35− Extensions: ViewPatterns

36+ Extensions: ViewPatterns,

37+ RankNTypes,

38+ ExistentialQuantification,

39+ ScopedTypeVariables

36 ghc-options: -Wall

40 ghc-options: -Wall

37 HS-Source-Dirs: src

41 HS-Source-Dirs: src

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

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TemplateHaskell #-}

1module Control.Distributed.Process.Backend.Azure

2module Control.Distributed.Process.Backend.Azure

2 ( -- * Initialization

3 ( -- * Initialization

3 Backend(..)

4 Backend(..)

@@ -13,13 +14,14 @@ import System.Environment (getEnv)

13import System.FilePath ((</>), takeFileName)

14import System.FilePath ((</>), takeFileName)

14import System.Environment.Executable (getExecutablePath)

15import System.Environment.Executable (getExecutablePath)

15import System.Posix.Types (Fd)

16import System.Posix.Types (Fd)

16−import Data.Binary (encode)

17+import Data.Binary (encode, decode)

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

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

18−import qualified Data.ByteString.Lazy as BSL (readFile)

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

19−import qualified Data.ByteString.Lazy.Char8 as BSLC (putStr)

20+import Data.Typeable (Typeable)

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

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

21import Control.Monad (void)

22import Control.Monad (void)

22import Control.Exception (catches, Handler(Handler))

23import Control.Exception (catches, Handler(Handler))

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

24-- Azure

26-- Azure

25import Network.Azure.ServiceManagement

27import Network.Azure.ServiceManagement

@@ -61,7 +63,23 @@ import qualified Network.SSH.Client.LibSSH2.ByteString.Lazy as SSHBS

61import Control.Distributed.Process

63import Control.Distributed.Process

62 ( Closure

64 ( Closure

63 , Process

65 , Process

66+ , Static

64 )

67 )

68+import Control.Distributed.Process.Closure

69+ ( remotable

70+ , mkClosure

71+ , cpBind

72+ , SerializableDict(SerializableDict)

73+ )

74+import Control.Distributed.Process.Serializable (Serializable)

75+

76+encodeToStdout :: Serializable a => a -> Process ()

77+encodeToStdout = liftIO . BSL.putStr . encode

78+

79+encodeToStdoutDict :: SerializableDict a -> a -> Process ()

80+encodeToStdoutDict SerializableDict = encodeToStdout

81+

82+remotable ['encodeToStdoutDict]

66-- | Azure backend

84-- | Azure backend

67data Backend = Backend {

85data Backend = Backend {

@@ -71,8 +89,8 @@ data Backend = Backend {

71 , copyToVM :: VirtualMachine -> IO ()

89 , copyToVM :: VirtualMachine -> IO ()

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

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

73 , checkMD5 :: VirtualMachine -> IO Bool

91 , checkMD5 :: VirtualMachine -> IO Bool

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

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

75− , runOnVM :: VirtualMachine -> String -> Closure (Process ()) -> IO ()

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

76 }

94 }

78data AzureParameters = AzureParameters {

96data AzureParameters = AzureParameters {

@@ -120,7 +138,7 @@ initializeBackend params = do

120 cloudServices = Azure.cloudServices setup

138 cloudServices = Azure.cloudServices setup

121 , copyToVM = apiCopyToVM params

139 , copyToVM = apiCopyToVM params

122 , checkMD5 = apiCheckMD5 params

140 , checkMD5 = apiCheckMD5 params

123− , runOnVM = apiRunOnVM params

141+ , callOnVM = apiCallOnVM params

124 }

142 }

125

143

126-- | Start a CH node on the given virtual machine

144-- | Start a CH node on the given virtual machine

@@ -129,21 +147,24 @@ apiCopyToVM params vm =

129 void . withSSH2 params vm $ \fd s -> catchSshError s $

147 void . withSSH2 params vm $ \fd s -> catchSshError s $

130 SSH.scpSendFile fd s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)

148 SSH.scpSendFile fd s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)

131

149

132−-- | Start the executable on the remote machine

150+-- | Call a process on a VM

133−apiRunOnVM :: AzureParameters -> VirtualMachine -> String -> Closure (Process ()) -> IO ()

151+apiCallOnVM :: Serializable a => AzureParameters -> Static (SerializableDict a) -> VirtualMachine -> String -> Closure (Process a) -> IO a

134−apiRunOnVM params vm port proc =

152+apiCallOnVM params dict vm port proc =

135− void . withSSH2 params vm $ \fd s -> do

153+ withSSH2 params vm $ \fd s -> do

136− let exe = "PATH=. " ++ azureSshRemotePath params

154+ let exe = "PATH=. " ++ azureSshRemotePath params

137− ++ " onvm run "

155+ ++ " onvm run "

138− ++ " --host " ++ vmIpAddress vm

156+ ++ " --host " ++ vmIpAddress vm

139− ++ " --port " ++ port

157+ ++ " --port " ++ port

140− ++ " 2>&1"

158+ ++ " 2>&1"

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

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

142− SSH.retryIfNeeded fd s $ SSH.channelExecute ch exe

160+ SSH.retryIfNeeded fd s $ SSH.channelExecute ch exe

143− SSHBS.writeChannel fd ch (encode proc)

161+ SSHBS.writeChannel fd ch (encode proc)

144− SSH.channelSendEOF ch

162+ SSH.channelSendEOF ch

145− SSHBS.readAllChannel fd ch

163+ SSHBS.readAllChannel fd ch

146− BSLC.putStr r

164+ return (decode r)

165+ where

166+ proc' :: Closure (Process ())

167+ proc' = proc `cpBind` undefined

147

168

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

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

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

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

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

@@ -1,16 +1,19 @@

1{-# LANGUAGE TemplateHaskell #-}

3import Control.Monad.IO.Class (liftIO)

4−import Control.Distributed.Process (Process)

4+import Control.Distributed.Process (Process, ProcessId, getSelfPid)

5−import Control.Distributed.Process.Closure (remotable, mkClosure)

5+import Control.Distributed.Process.Closure (remotable, mkClosure, sdictProcessId)

6−import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)

6+import Control.Distributed.Process.Backend.Azure.GenericMain

7+ ( genericMain

8+ , ProcessPair(..)

9+ )

8−cprint :: String -> Process ()

11+getPid :: () -> Process ProcessId

9−cprint = liftIO . putStrLn

12+getPid () = getSelfPid

11−remotable ['cprint]

14+remotable ['getPid]

13main = genericMain __remoteTable $ \cmd ->

16main = genericMain __remoteTable $ \cmd ->

14 case cmd of

17 case cmd of

15− "hello" -> return $ $(mkClosure 'cprint) "Hi world!"

18+ "hello" -> return $ ProcessPair ($(mkClosure 'getPid) ()) print sdictProcessId

16 _ -> error "unknown command"

19 _ -> error "unknown command"

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

@@ -1,5 +1,8 @@

1-- | Generic main

2−module Control.Distributed.Process.Backend.Azure.GenericMain (genericMain) where

2+module Control.Distributed.Process.Backend.Azure.GenericMain

3+ ( genericMain

4+ , ProcessPair(..)

5+ ) where

4import Prelude hiding (catch)

7import Prelude hiding (catch)

5import System.Exit (exitSuccess, exitFailure)

8import System.Exit (exitSuccess, exitFailure)

@@ -20,7 +23,7 @@ import Control.Distributed.Process.Backend.Azure

20 , cloudServices

23 , cloudServices

21 , CloudService(cloudServiceName, cloudServiceVMs)

24 , CloudService(cloudServiceName, cloudServiceVMs)

22 , VirtualMachine(vmName)

25 , VirtualMachine(vmName)

23− , Backend(copyToVM, checkMD5, runOnVM)

26+ , Backend(copyToVM, checkMD5, callOnVM)

24 )

27 )

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

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

26 ( initialize

29 ( initialize

@@ -49,16 +52,25 @@ import Control.Distributed.Process

49 , Closure

52 , Closure

50 , Process

53 , Process

51 , unClosure

54 , unClosure

55+ , Static

52 )

56 )

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

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

58+import Control.Distributed.Process.Serializable (Serializable)

59+import Control.Distributed.Process.Closure (SerializableDict)

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

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

56--------------------------------------------------------------------------------

62--------------------------------------------------------------------------------

57-- Main --

63-- Main --

58--------------------------------------------------------------------------------

64--------------------------------------------------------------------------------

66+data ProcessPair b = forall a. Serializable a => ProcessPair {

67+ ppairRemote :: Closure (Process a)

68+ , ppairLocal :: a -> IO b

69+ , ppairDict :: Static (SerializableDict a)

70+ }

71+

60−genericMain :: (RemoteTable -> RemoteTable) -- ^ Standard CH remote table

72+genericMain :: (RemoteTable -> RemoteTable) -- ^ Standard CH remote table

61− -> (String -> IO (Closure (Process ()))) -- ^ Closures to support in 'run'

73+ -> (String -> IO (ProcessPair ())) -- ^ Closures to support in 'run'

62 -> IO ()

74 -> IO ()

63genericMain remoteTable cmds = do

75genericMain remoteTable cmds = do

64 _ <- SSH.initialize True

76 _ <- SSH.initialize True

@@ -90,13 +102,15 @@ genericMain remoteTable cmds = do

90 then exitSuccess

102 then exitSuccess

91 else exitFailure

103 else exitFailure

92 RunOn {} -> do

104 RunOn {} -> do

93− closure <- cmds (closureId cmd)

105+ procPair <- cmds (closureId cmd)

94− params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

106+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

95− backend <- initializeBackend params

107+ backend <- initializeBackend params

96− css <- cloudServices backend

108+ css <- cloudServices backend

97 forM_ (findTarget (target cmd) css) $ \vm -> do

109 forM_ (findTarget (target cmd) css) $ \vm -> do

98 putStr (vmName vm ++ ": ") >> hFlush stdout

110 putStr (vmName vm ++ ": ") >> hFlush stdout

111+ case procPair of

112+ ProcessPair rProc lProc dict ->

99− runOnVM backend vm (remotePort cmd) closure

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

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

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

101 onVmRun (remoteTable initRemoteTable) (onVmIP vmCmd) (onVmPort vmCmd)

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

102 SSH.exit

116 SSH.exit

distributed-process/ChangeLog+1−1

@@ -1,6 +1,6 @@

12012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.2.1

3−* Expose the constructors of Closure and Static

3+* Expose the constructors of Closure

4* Improved docs

62012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

distributed-process/src/Control/Distributed/Process.hs+1−1

@@ -64,7 +64,7 @@ module Control.Distributed.Process

64 , DiedReason(..)

65 -- * Closures

66 , Closure(..)

67− , Static(..)

67+ , Static

68 , unClosure

69 , RemoteTable

70 -- * Logging