add a `Caller'.

Ilya Portnov [2010-04-21 14:33:35]
add a `Caller'.
Filename
Caller.hs
Dispatcher.hs
Server.hs
TestCall.hs
YAMLInstances.hs
diff --git a/Caller.hs b/Caller.hs
new file mode 100644
index 0000000..0d7c404
--- /dev/null
+++ b/Caller.hs
@@ -0,0 +1,28 @@
+
+module Caller where
+
+import qualified Data.Map as M
+import Data.Object.Yaml
+import Data.Convertible.Base
+import qualified Data.ByteString.Char8 as BS
+import Network
+import System.IO
+
+import YAML
+import YAMLInstances
+import Server
+
+call :: (IsYamlObject a, IsYamlObject b) => (String -> IO (String,Int)) -> String -> String -> a -> IO b
+call getServer service name args = withSocketsDo $ do
+  (host,port) <- getServer service
+  h <- connectTo host (PortNumber $ fromIntegral port)
+  let c = mkCall name (cs args)
+      s = serialize c
+  hSetBuffering h NoBuffering
+  BS.hPutStrLn h s
+  lns <- readHandle h []
+  hClose h
+  let text = BS.unlines lns
+  case unserialize text of
+    Nothing -> fail "No answer"
+    Just x -> return x
diff --git a/Dispatcher.hs b/Dispatcher.hs
index 0835865..5b49cad 100644
--- a/Dispatcher.hs
+++ b/Dispatcher.hs
@@ -16,13 +16,13 @@ type Rules = M.Map BS.ByteString Worker
 mkRules :: [(String,Worker)] -> Rules
 mkRules pairs = M.fromList [(BS.pack name, worker) | (name,worker) <- pairs]

-dispatch :: Rules -> (YamlObject -> IO YamlObject)
-dispatch rules obj = do
+dispatch :: Rules -> Worker
+dispatch rules = \obj ->
   let call :: Call
       call = cs obj
-  case M.lookup (methodName call) rules of
-    Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call)
-    Just fn -> fn (args call)
+  in case M.lookup (methodName call) rules of
+      Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call)
+      Just fn -> fn (args call)

 dispatcher :: Int -> Rules -> IO ()
 dispatcher port rules = server port (dispatch rules)
diff --git a/Server.hs b/Server.hs
index 01780ef..03f7ed5 100644
--- a/Server.hs
+++ b/Server.hs
@@ -15,16 +15,18 @@ import YAMLInstances

 (<+>) = BS.append

-read' :: Handle -> [BS.ByteString] -> IO [BS.ByteString]
-read' h acc = do
+readHandle :: Handle -> [BS.ByteString] -> IO [BS.ByteString]
+readHandle h acc = do
     line <- BS.hGetLine h
-    let line' = if (BS.last line)=='\r'
-                  then BS.init line
-                  else line
+    let line' = if BS.null line
+                  then line
+                  else if (BS.last line)=='\r'
+                          then BS.init line
+                          else line
 --           print $ "read line:"++line'
     if BS.null line'
       then return acc
-      else read' h (acc ++ [line'])
+      else readHandle h (acc ++ [line'])

 server ::
       Int
@@ -40,13 +42,14 @@ server port callOut = do
          do (h,_nm,_port) <- accept sock
             forkIO
               (do
-                lns <- read' h []
+                hSetBuffering h NoBuffering
+                lns <- readHandle h []
                 let text = BS.unlines lns
                 case unserialize text of
                   Nothing -> hClose h
                   Just ob -> do
                     print ob
                     res <- callOut ob
-                    BS.hPutStr h $ serialize res
+                    BS.hPutStrLn h $ serialize res
                     hClose h)

diff --git a/TestCall.hs b/TestCall.hs
new file mode 100644
index 0000000..76d9e27
--- /dev/null
+++ b/TestCall.hs
@@ -0,0 +1,16 @@
+
+import Data.Object.Yaml
+import Data.Convertible.Base
+
+import YAML
+import YAMLInstances
+import Caller
+
+getServer "test" = return ("127.0.0.1", 5000)
+getServer _ = fail "Unknown service"
+
+p = Point 2.0 3.0
+
+main = do
+  r <- call getServer "test" "double" p
+  print (r :: Point)
diff --git a/YAMLInstances.hs b/YAMLInstances.hs
index 676135a..df6da1b 100644
--- a/YAMLInstances.hs
+++ b/YAMLInstances.hs
@@ -45,8 +45,8 @@ instance IsYamlObject YamlObject where
 data Call = Call { methodName :: BS.ByteString, args :: YamlObject }
   deriving (Show)

-call :: String -> YamlObject -> YamlObject
-call name args = cs $ Call (BS.pack name) args
+mkCall :: String -> YamlObject -> YamlObject
+mkCall name args = cs $ Call (BS.pack name) args

 instance ConvertSuccess Call YamlObject where
   convertSuccess (Call name args) = Mapping [(toYamlScalar "call", Scalar $ toYamlScalar name),
ViewGit