4624c46 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Cleanup

4624c46Edsko de Vries14 years ago

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+44−64

compare with master

unifiedsplit

@@ -629,29 +629,7 @@ apiCallOnVM :: AzureParameters

629 -> String

630 -> ProcessPair a

631 -> IO a

632−apiCallOnVM params cloudService vm port ppair =

632+apiCallOnVM = runOnVM False

633− withSSH2 params vm $ \s -> do

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

635− ++ " onvm"

636− ++ " " ++ vmIpAddress vm

637− ++ " " ++ port

638− ++ " " ++ cloudService

639− ++ " False"

640− ++ " 2>&1"

641− let paramsEnc = encode params

642− (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do

643− SSH.channelExecute ch exe

644− SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))

645− SSH.writeAllChannel ch rprocEnc

646− SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))

647− SSH.writeAllChannel ch paramsEnc

648− runLocalProcess (ppairLocal ppair) ch

649− if status == 0

650− then return r

651− else error "callOnVM: Non-zero exit status"

652− where

653− rprocEnc :: BSL.ByteString

654− rprocEnc = encode (ppairRemote ppair)

655

633

656apiSpawnOnVM :: AzureParameters

634apiSpawnOnVM :: AzureParameters

657 -> String

635 -> String

@@ -659,37 +637,40 @@ apiSpawnOnVM :: AzureParameters

659 -> String

637 -> String

660 -> Closure (Backend -> Process ())

638 -> Closure (Backend -> Process ())

661 -> IO ProcessId

639 -> IO ProcessId

662−apiSpawnOnVM params cloudService vm port proc =

640+apiSpawnOnVM params cloudService vm port rproc =

641+ runOnVM True params cloudService vm port $

642+ ProcessPair rproc localExpect

643+

644+-- | Internal generalization of 'spawnOnVM' and 'callOnVM'

645+runOnVM :: Bool

646+ -> AzureParameters

647+ -> String

648+ -> VirtualMachine

649+ -> String

650+ -> ProcessPair a

651+ -> IO a

652+runOnVM bg params cloudService vm port ppair =

663− withSSH2 params vm $ \s -> do

653+ withSSH2 params vm $ \s -> do

664− -- TODO: reduce duplication with apiCallOnVM

654+ -- TODO: reduce duplication with apiCallOnVM

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

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

666− ++ " onvm"

656+ ++ " onvm"

667− ++ " " ++ vmIpAddress vm

657+ ++ " " ++ vmIpAddress vm

668− ++ " " ++ port

658+ ++ " " ++ port

669− ++ " " ++ cloudService

659+ ++ " " ++ cloudService

670− ++ " True"

660+ ++ " " ++ show bg

671− ++ " 2>&1"

661+ ++ " 2>&1"

672− let paramsEnc = encode params

662+ let paramsEnc = encode params

663+ let rprocEnc = encode (ppairRemote ppair)

673− (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do

664+ (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do

674− SSH.channelExecute ch exe

665+ SSH.channelExecute ch exe

675− SSH.writeChannel ch (encodeInt32 (BSL.length procEnc))

666+ SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))

676− SSH.writeAllChannel ch procEnc

667+ SSH.writeAllChannel ch rprocEnc

677− SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))

668+ SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))

678− SSH.writeAllChannel ch paramsEnc

669+ SSH.writeAllChannel ch paramsEnc

679− localExpect' ch

670+ runLocalProcess (ppairLocal ppair) ch

680− if status == 0

671+ if status == 0

681− then return r

672+ then return r

682− else error "spawnOnVM: Non-zero exit status"

673+ else error "runOnVM: Non-zero exit status" -- This would a bug

683− {-

684− --SSH.channelSendEOF ch

685− --SSH.readAllChannel ch

686− if status == 0

687− then return (decode r)

688− else error (BSLC.unpack r)

689− -}

690− where

691− procEnc :: BSL.ByteString

692− procEnc = encode proc

693

674

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

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

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

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

@@ -784,16 +765,15 @@ localSend x = LocalProcess $ do

784-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a

765-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a

785-- runtime error if the remote process sends a message of type other than @a@.

766-- runtime error if the remote process sends a message of type other than @a@.

786localExpect :: Serializable a => LocalProcess a

767localExpect :: Serializable a => LocalProcess a

787−localExpect = LocalProcess $ ask >>= liftIO . localExpect'

768+localExpect = LocalProcess $ do

788−

769+ ch <- ask

789−localExpect' :: Serializable a => SSH.Channel -> IO a

770+ liftIO $ do

790−localExpect' ch = do

791− isE <- readIntChannel ch

771+ isE <- readIntChannel ch

792− len <- readIntChannel ch

772+ len <- readIntChannel ch

793− msg <- readSizeChannel ch len

773+ msg <- readSizeChannel ch len

794− if isE /= 0

774+ if isE /= 0

795− then error (decode msg)

775+ then error (decode msg)

796− else return (decode msg)

776+ else return (decode msg)

797

777

798-- | Send a message from the remote process to the local process (see

778-- | Send a message from the remote process to the local process (see

799-- 'ProcessPair'). Note that the remote process can use the standard Cloud

779-- 'ProcessPair'). Note that the remote process can use the standard Cloud