Skip to content

Commit b0b76de

Browse files
edskoedsko
committed
Run an arbitrary process closure on a VM
1 parent 21dd5c1 commit b0b76de

File tree

4 files changed

+55
-24
lines changed

4 files changed

+55
-24
lines changed

‎distributed-process-azure/distributed-process-azure.cabal

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -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

Lines changed: 21 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -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)
1617
import System.Posix.Types (Fd)
1718
import Data.Binary (encode, decode)
1819
import 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)
2021
import Data.Typeable (Typeable)
2122
import Control.Applicative ((<$>))
2223
import Control.Monad (void)
@@ -61,15 +62,18 @@ import qualified Network.SSH.Client.LibSSH2.ByteString.Lazy as SSHBS
6162

6263
-- CH
6364
import Control.Distributed.Process
64-
( Closure
65+
( Closure(Closure)
6566
, Process
6667
, Static
68+
, RemoteTable
6769
)
6870
import Control.Distributed.Process.Closure
6971
( remotable
70-
, mkClosure
7172
, cpBind
7273
, SerializableDict(SerializableDict)
74+
, staticConst
75+
, staticApply
76+
, mkStatic
7377
)
7478
import Control.Distributed.Process.Serializable (Serializable)
7579

@@ -79,7 +83,17 @@ encodeToStdout = liftIO . BSL.putStr . encode
7983
encodeToStdoutDict :: SerializableDict a -> a -> Process ()
8084
encodeToStdoutDict 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
8599
data 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
170184
apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool

‎distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,9 @@ import Control.Distributed.Process.Backend.Azure.GenericMain
99
)
1010

1111
getPid :: () -> Process ProcessId
12-
getPid () = getSelfPid
12+
getPid () = do
13+
liftIO $ appendFile "Log" "getPid did run"
14+
getSelfPid
1315

1416
remotable ['getPid]
1517

‎distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/GenericMain.hs

Lines changed: 28 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -13,23 +13,19 @@ import System.IO
1313
, hSetBinaryMode
1414
)
1515
import Data.Binary (decode)
16-
import qualified Data.ByteString.Lazy as BSL (ByteString, getContents)
16+
import qualified Data.ByteString.Lazy as BSL (ByteString, getContents, length)
1717
import 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
2823
import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
2924
( initialize
3025
, exit
3126
)
32-
import Control.Applicative ((<$>), (<*>), (<|>))
27+
28+
-- Command line options
3329
import Options.Applicative
3430
( Parser
3531
, strOption
@@ -47,17 +43,30 @@ import Options.Applicative
4743
, header
4844
, switch
4945
)
46+
47+
-- CH
5048
import Control.Distributed.Process
5149
( RemoteTable
5250
, Closure
5351
, Process
5452
, unClosure
5553
, Static
54+
, catch
5655
)
5756
import Control.Distributed.Process.Node (newLocalNode, runProcess, initRemoteTable)
5857
import Control.Distributed.Process.Serializable (Serializable)
5958
import Control.Distributed.Process.Closure (SerializableDict)
6059
import 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
144155
onVmRun :: RemoteTable -> String -> String -> IO ()
145156
onVmRun 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 --

0 commit comments

Comments
 (0)