Support for parallel execution of method on many servers

Ilya V. Portnov [2010-04-23 06:13:37]
Support for parallel execution of method on many servers
Filename
Network/YAML/Caller.hs
Network/YAML/Derive.hs
Test.hs
TestCall.hs
diff --git a/Network/YAML/Caller.hs b/Network/YAML/Caller.hs
index 00c39b8..3f037c5 100644
--- a/Network/YAML/Caller.hs
+++ b/Network/YAML/Caller.hs
@@ -8,6 +8,8 @@ import Data.Convertible.Base
 import qualified Data.ByteString.Char8 as BS
 import Network
 import System.IO
+import Control.Monad
+import Control.Concurrent

 import Network.YAML.Base
 import Network.YAML.Instances
@@ -43,3 +45,29 @@ callDynamic getServer service name args = do
   srv <- getServer service
   call srv name args

+-- | Call a method and put it's result into MVar
+callF :: (IsYamlObject a, IsYamlObject b)
+      => (BS.ByteString -> IO (BS.ByteString, Int))           -- ^ Get (Host, port) from service name
+      -> BS.ByteString                                        -- ^ Service name
+      -> BS.ByteString                                        -- ^ Method name
+      -> (a, MVar b)                                          -- ^ (Argument, MVar for result)
+      -> IO ()
+callF getServer service name (args, var) = do
+  srv <- getServer service
+  r <- call srv name args
+  putMVar var r
+
+-- | Call a method for each argument in the list in parallel
+-- (it can run method for each argument on another server)
+callP :: (IsYamlObject a, IsYamlObject b)
+      => (BS.ByteString -> IO (BS.ByteString, Int))      -- ^ Get (Host, port) from service name
+      -> BS.ByteString                                   -- ^ Service name
+      -> BS.ByteString                                   -- ^ Method name
+      -> [a]                                             -- ^ List of arguments
+      -> IO [b]
+callP getServer service name args = do
+  let n = length args
+  vars <- replicateM n newEmptyMVar
+  mapM (forkIO . callF getServer service name) $ zip args vars
+  mapM takeMVar vars
+
diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs
index 44dfbda..1c5c6cd 100644
--- a/Network/YAML/Derive.hs
+++ b/Network/YAML/Derive.hs
@@ -13,7 +13,6 @@ import Data.Object.Yaml
 import qualified Data.ByteString.Char8 as BS

 import Network.YAML.Base
-import Network.YAML.Instances

 mkList :: [Name] -> ExpQ
 mkList []       = [| [] |]
diff --git a/Test.hs b/Test.hs
index 4e76087..4ce1668 100644
--- a/Test.hs
+++ b/Test.hs
@@ -13,7 +13,11 @@ import TestTypes
 double :: Point -> IO Point
 double (Point x y) = return $ Point (x*2) (y*2)

-rules = mkRules [("double", yamlMethod double)]
+mySum :: [Double] -> IO Double
+mySum = return . sum
+
+rules = mkRules [("double", yamlMethod double),
+                 ("sum",    yamlMethod mySum)]

 main = do
   putStrLn "Listening..."
diff --git a/TestCall.hs b/TestCall.hs
index 1c3670b..380243a 100644
--- a/TestCall.hs
+++ b/TestCall.hs
@@ -14,7 +14,13 @@ getService _ = fail "Unknown service"

 p = Point 2.0 3.0

+ps = [Point 3.0 5.0, Point 1.0 2.1, Point 0.1 0.2]
+
 main = do
   srv <- getService "test"
   r <- call srv "double" p
   print (r :: Point)
+  s <- call srv "sum" ([3.5, 5.5, 1.0] :: [Double])
+  print (s :: Double)
+  rs <- callP getService "test" "double" ps
+  print (rs :: [Point])
ViewGit