git.iko.soy/distributed-process
on master help sign in
Deal with exit status/Simple ping server+client
94336e6Edsko de Vries
distributed-process-azure/distributed-process-azure.cabal+3−1
compare with master
unifiedsplit
@@ -47,4 +47,6 @@ Executable cloud-haskell-azure
47 Build-Depends: base >= 4.4 && < 5,
47 Build-Depends: base >= 4.4 && < 5,
48 distributed-process-azure >= 0.1 && < 0.2,
48 distributed-process-azure >= 0.1 && < 0.2,
49 distributed-process >= 0.2 && < 0.3,
49 distributed-process >= 0.2 && < 0.3,
50− transformers >= 0.3 && < 0.4
50+ transformers >= 0.3 && < 0.4,
51+ bytestring >= 0.9 && < 0.11,
52+ binary >= 0.5 && < 0.6
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+9−4
@@ -18,6 +18,7 @@ import Data.Binary (encode, decode)
18import Data.Digest.Pure.MD5 (md5, MD5Digest)
18import Data.Digest.Pure.MD5 (md5, MD5Digest)
19import qualified Data.ByteString.Char8 as BSSC (pack)
19import qualified Data.ByteString.Char8 as BSSC (pack)
20import qualified Data.ByteString.Lazy as BSL (ByteString, readFile, putStr, writeFile)
20import qualified Data.ByteString.Lazy as BSL (ByteString, readFile, putStr, writeFile)
21+import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)
21import Data.Typeable (Typeable)
22import Data.Typeable (Typeable)
22import Control.Applicative ((<$>))
23import Control.Applicative ((<$>))
23import Control.Monad (void)
24import Control.Monad (void)
@@ -171,12 +172,14 @@ apiCallOnVM params dict vm port proc =
171 ++ " --host " ++ vmIpAddress vm
172 ++ " --host " ++ vmIpAddress vm
172 ++ " --port " ++ port
173 ++ " --port " ++ port
173 ++ " 2>&1"
174 ++ " 2>&1"
174− (_, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
175+ (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
175 SSH.channelExecute ch exe
176 SSH.channelExecute ch exe
176 _cnt <- SSH.writeAllChannel ch (encode $ proc `cpBind` cpEncodeToStdout dict)
177 _cnt <- SSH.writeAllChannel ch (encode $ proc `cpBind` cpEncodeToStdout dict)
177 SSH.channelSendEOF ch
178 SSH.channelSendEOF ch
178 SSH.readAllChannel ch
179 SSH.readAllChannel ch
180+ if status == 0
179− return (decode r)
181+ then return $ decode r
182+ else error (BSLC.unpack r)
180
183
181apiSpawnOnVM :: AzureParameters -> VirtualMachine -> String -> Closure (Process ()) -> IO ()
184apiSpawnOnVM :: AzureParameters -> VirtualMachine -> String -> Closure (Process ()) -> IO ()
182apiSpawnOnVM params vm port proc =
185apiSpawnOnVM params vm port proc =
@@ -188,12 +191,14 @@ apiSpawnOnVM params vm port proc =
188 ++ " --background "
191 ++ " --background "
189 ++ " 2>&1"
192 ++ " 2>&1"
190 BSL.writeFile "closure" (encode proc)
193 BSL.writeFile "closure" (encode proc)
191− r <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
194+ (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do
192 SSH.channelExecute ch exe
195 SSH.channelExecute ch exe
193 _cnt <- SSH.writeAllChannel ch (encode proc)
196 _cnt <- SSH.writeAllChannel ch (encode proc)
194 SSH.channelSendEOF ch
197 SSH.channelSendEOF ch
195 SSH.readAllChannel ch
198 SSH.readAllChannel ch
196− print r
199+ if status == 0
200+ then return ()
201+ else error (BSLC.unpack r)
197
202
198-- | Check the MD5 hash of the executable on the remote machine
203-- | Check the MD5 hash of the executable on the remote machine
199apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
204apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+56−19
@@ -1,37 +1,74 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2
2
3+import Data.Binary (encode, decode)
4+import Control.Applicative ((<$>))
5+import Control.Monad (forever)
3import Control.Monad.IO.Class (liftIO)
6import Control.Monad.IO.Class (liftIO)
4import Control.Concurrent (threadDelay)
7import Control.Concurrent (threadDelay)
5−import Control.Distributed.Process (Process, ProcessId, getSelfPid, Closure)
8+import Control.Exception (try, IOException)
9+import Control.Distributed.Process
10+ ( Process
11+ , ProcessId
12+ , getSelfPid
13+ , Closure
14+ , expect
15+ , send
16+ , monitor
17+ , receiveWait
18+ , match
19+ , ProcessMonitorNotification(..)
20+ )
6−import Control.Distributed.Process.Closure (remotable, mkClosure, sdictProcessId)
21+import Control.Distributed.Process.Closure
22+ ( remotable
23+ , mkClosure
24+ , SerializableDict(..)
25+ , mkStatic
26+ )
7import Control.Distributed.Process.Backend.Azure.GenericMain
27import Control.Distributed.Process.Backend.Azure.GenericMain
8 ( genericMain
28 ( genericMain
9 , ProcessPair(..)
29 , ProcessPair(..)
10 )
30 )
31+import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
32+
33+sdictString :: SerializableDict String
34+sdictString = SerializableDict
11
35
12−getPid :: () -> Process ProcessId
36+ping :: () -> Process String
13−getPid () = do
37+ping () = do
14− liftIO $ appendFile "Log" "getPid did run"
38+ mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")
39+ case mPingServerEnc of
40+ Left err ->
41+ return $ "Ping server not found: " ++ show (err :: IOException)
42+ Right pingServerEnc -> do
43+ let pingServer = decode pingServerEnc
15− getSelfPid
44+ pid <- getSelfPid
45+ monitor pingServer
46+ send pingServer pid
47+ gotReply <- receiveWait
48+ [ match (\() -> return True)
49+ , match (\(ProcessMonitorNotification _ _ _) -> return False)
50+ ]
51+ if gotReply
52+ then return $ "Ping server at " ++ show pingServer ++ " ok"
53+ else return $ "Ping server at " ++ show pingServer ++ " failure"
16
54
17−logN :: Int -> Process ()
55+pingServer :: () -> Process ()
18−logN 0 =
56+pingServer () = do
19− liftIO $ appendFile "Log" "logN done\n"
57+ pid <- getSelfPid
20−logN n = do
58+ liftIO $ BSL.writeFile "pingServer.pid" (encode pid)
21− liftIO $ do
59+ forever $ do
22− appendFile "Log" $ "logN " ++ show n ++ "\n"
60+ pid <- expect
23− threadDelay 1000000
61+ send pid ()
24− logN (n - 1)
25
62
26−remotable ['getPid, 'logN]
63+remotable ['ping, 'pingServer, 'sdictString]
27
64
28main :: IO ()
65main :: IO ()
29main = genericMain __remoteTable callable spawnable
66main = genericMain __remoteTable callable spawnable
30 where
67 where
31 callable :: String -> IO (ProcessPair ())
68 callable :: String -> IO (ProcessPair ())
32− callable "getPid" = return $ ProcessPair ($(mkClosure 'getPid) ()) print sdictProcessId
69+ callable "ping" = return $ ProcessPair ($(mkClosure 'ping) ()) putStrLn $(mkStatic 'sdictString)
33− callable _ = error "spawnable: unknown"
70+ callable _ = error "spawnable: unknown"
34
71
35 spawnable :: String -> IO (Closure (Process ()))
72 spawnable :: String -> IO (Closure (Process ()))
36− spawnable "logN" = return $ $(mkClosure 'logN) (10 :: Int)
73+ spawnable "pingServer" = return $ $(mkClosure 'pingServer) ()
37− spawnable _ = error "callable: unknown"
74+ spawnable _ = error "callable: unknown"