add a `Caller'.
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),