git.iko.soy/distributed-process
on ryan help sign in
distributed-process/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs
74 lines 2.1 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3import Data.Binary (encode, decode)
4import Control.Applicative ((<$>))
5import Control.Monad (forever)
6import Control.Monad.IO.Class (liftIO)
7import Control.Concurrent (threadDelay)
8import Control.Exception (try, IOException)
9import Control.Distributed.Process
10 ( Process
11 , ProcessId
12 , getSelfPid
13 , Closure
14 , expect
15 , send
16 , monitor
17 , receiveWait
18 , match
19 , ProcessMonitorNotification(..)
20 )
21import Control.Distributed.Process.Closure
22 ( remotable
23 , mkClosure
24 , SerializableDict(..)
25 , mkStatic
26 )
27import Control.Distributed.Process.Backend.Azure.GenericMain
28 ( genericMain
29 , ProcessPair(..)
30 )
31import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)
33sdictString :: SerializableDict String
34sdictString = SerializableDict
36ping :: () -> Process String
37ping () = 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"
55pingServer :: () -> Process ()
56pingServer () = do
57 pid <- getSelfPid
58 liftIO $ BSL.writeFile "pingServer.pid" (encode pid)
59 forever $ do
60 pid <- expect
61 send pid ()
63remotable ['ping, 'pingServer, 'sdictString]
65main :: IO ()
66main = genericMain __remoteTable callable spawnable
67 where
68 callable :: String -> IO (ProcessPair ())
69 callable "ping" = return $ ProcessPair ($(mkClosure 'ping) ()) putStrLn $(mkStatic 'sdictString)
70 callable _ = error "spawnable: unknown"
72 spawnable :: String -> IO (Closure (Process ()))
73 spawnable "pingServer" = return $ $(mkClosure 'pingServer) ()
74 spawnable _ = error "callable: unknown"