@@ -1,37 +1,74 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3+import Data.Binary (encode, decode)
4+import Control.Applicative ((<$>))
5+import Control.Monad (forever)
36import Control.Monad.IO.Class (liftIO)
47import Control.Concurrent (threadDelay)
5−import Control.Distributed.Process (Process, ProcessId, getSelfPid, Closure)
6−import Control.Distributed.Process.Closure (remotable, mkClosure, sdictProcessId)
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+ )
21+import Control.Distributed.Process.Closure
22+ ( remotable
23+ , mkClosure
24+ , SerializableDict(..)
25+ , mkStatic
26+ )
727import Control.Distributed.Process.Backend.Azure.GenericMain
828 ( genericMain
929 , ProcessPair(..)
1030 )
31+import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
32+
33+sdictString :: SerializableDict String
34+sdictString = SerializableDict
1135
12−getPid :: () -> Process ProcessId
13−getPid () = do
14− liftIO $ appendFile "Log" "getPid did run"
15− getSelfPid
36+ping :: () -> Process String
37+ping () = do
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
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"
1654
17−logN :: Int -> Process ()
18−logN 0 =
19− liftIO $ appendFile "Log" "logN done\n"
20−logN n = do
21− liftIO $ do
22− appendFile "Log" $ "logN " ++ show n ++ "\n"
23− threadDelay 1000000
24− logN (n - 1)
55+pingServer :: () -> Process ()
56+pingServer () = do
57+ pid <- getSelfPid
58+ liftIO $ BSL.writeFile "pingServer.pid" (encode pid)
59+ forever $ do
60+ pid <- expect
61+ send pid ()
2562
26−remotable ['getPid, 'logN]
63+remotable ['ping, 'pingServer, 'sdictString]
2764
2865main :: IO ()
2966main = genericMain __remoteTable callable spawnable
3067 where
3168 callable :: String -> IO (ProcessPair ())
32− callable "getPid" = return $ ProcessPair ($(mkClosure 'getPid) ()) print sdictProcessId
33− callable _ = error "spawnable: unknown"
69+ callable "ping" = return $ ProcessPair ($(mkClosure 'ping) ()) putStrLn $(mkStatic 'sdictString)
70+ callable _ = error "spawnable: unknown"
3471
3572 spawnable :: String -> IO (Closure (Process ()))
36− spawnable "logN" = return $ $(mkClosure 'logN) (10 :: Int)
37− spawnable _ = error "callable: unknown"
73+ spawnable "pingServer" = return $ $(mkClosure 'pingServer) ()
74+ spawnable _ = error "callable: unknown"