yaml-rpc 0.1 → 0.2
raw patch · 12 files changed
+235/−54 lines, 12 files
Files
- Network/YAML.hs +2/−0
- Network/YAML/Balancer.hs +4/−4
- Network/YAML/Base.hs +2/−0
- Network/YAML/Caller.hs +57/−15
- Network/YAML/Dispatcher.hs +3/−0
- Network/YAML/Instances.hs +44/−0
- Network/YAML/Server.hs +52/−11
- Network/YAML/WrapMethods.hs +27/−2
- README +8/−0
- Test.hs +3/−3
- TestCall.hs +32/−18
- yaml-rpc.cabal +1/−1
Network/YAML.hs view
@@ -7,9 +7,11 @@ module Network.YAML.Dispatcher, module Network.YAML.Balancer, module Network.YAML.WrapMethods,+ HostAndPort, forkA ) where +import Network.YAML.Base (HostAndPort) import Network.YAML.Caller import Network.YAML.Instances import Network.YAML.Derive
Network/YAML/Balancer.hs view
@@ -4,12 +4,12 @@ import System.Random import qualified Data.ByteString.Char8 as BS -type Server = (BS.ByteString, Int)+import Network.YAML.Base (HostAndPort) -- | Select random server-selectRandom :: [(BS.ByteString, Server, Int)] -- ^ [(Service name, (hostname, port number), priority)]- -> BS.ByteString -- ^ Service name- -> IO Server+selectRandom :: [(BS.ByteString, HostAndPort, Int)] -- ^ [(Service name, (hostname, port number), priority)]+ -> BS.ByteString -- ^ Service name+ -> IO HostAndPort selectRandom lst service = do let lst' = concatMap (\(name,srv,p) -> replicate p (name, srv)) lst lst'' = map snd $ filter (\(name,srv) -> name==service) lst'
Network/YAML/Base.hs view
@@ -10,6 +10,8 @@ import qualified Data.ByteString.Char8 as BS import Text.Libyaml hiding (encode, decode) +type HostAndPort = (BS.ByteString, Int)+ class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject, Default a) => IsYamlObject a where getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject
Network/YAML/Caller.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} module Network.YAML.Caller where @@ -15,6 +15,16 @@ import Network.YAML.Instances import Network.YAML.Server +class Connection c where+ newConnection :: (BS.ByteString, Int) -> IO c+ closeConnection :: c -> IO ()+ -- | Call remote method+ call :: (IsYamlObject a, IsYamlObject b)+ => c+ -> BS.ByteString -- ^ Name of method+ -> a -- ^ Argument for method+ -> IO b+ -- | Send any YAML text and return an answer sendYAML :: (BS.ByteString, Int) -- ^ (Hostname, port) -> BS.ByteString -- ^ YAML text@@ -28,21 +38,53 @@ let text = BS.unlines lns return text --- | Call remote method-call :: (IsYamlObject a, IsYamlObject b)- => (BS.ByteString, Int) -- ^ (Host name, port number)- -> BS.ByteString -- ^ Name of method- -> a -- ^ Argument for method- -> IO b-call (host,port) name args = do- let c = mkCall name (cs args)- s = serialize c- text <- sendYAML (host,port) s- case unserialize text of- Nothing -> fail "No answer"- Just x -> return x+-- | Send any YAML text and return an answer+hSendYAML :: Handle+ -> BS.ByteString -- ^ YAML text+ -> IO BS.ByteString -- ^ Answer+hSendYAML h yaml = withSocketsDo $ do+ hSetBuffering h NoBuffering+ BS.hPutStrLn h yaml+ lns <- readHandle h []+ let text = BS.unlines lns+ return text --- | Similar, but select server on each call+instance Connection HostAndPort where+ -- | Call remote method+-- call :: (IsYamlObject a, IsYamlObject b)+-- => (BS.ByteString, Int) -- ^ (Host name, port number)+-- -> BS.ByteString -- ^ Name of method+-- -> a -- ^ Argument for method+-- -> IO b+ call (host,port) name args = do+ let c = mkCall name (cs args)+ s = serialize c+ text <- sendYAML (host,port) s+ case unserialize text of+ Nothing -> fail "No answer"+ Just x -> return x++ newConnection pair = return pair+ closeConnection _ = return ()++newtype PersistentConnection = PC Handle++instance Connection PersistentConnection where+ newConnection (host, port) = do+ h <- connectTo (BS.unpack host) (PortNumber $ fromIntegral port)+ return (PC h)++ closeConnection (PC h) = hClose h++ call (PC h) name args = do+ let c = mkCall name (cs args)+ s = serialize c+ text <- hSendYAML h s+ case unserialize text of+ Nothing -> fail "No answer"+ Just x -> return x++-- | Similar to call, but select server on each call callDynamic :: (IsYamlObject a, IsYamlObject b) => (BS.ByteString -> IO (BS.ByteString,Int)) -- ^ Get (Host name, port number) from service name -> BS.ByteString -- ^ Name of the service
Network/YAML/Dispatcher.hs view
@@ -29,3 +29,6 @@ -- | Listens given port and dispatches requests dispatcher :: Int -> Rules -> IO () dispatcher port rules = server port (dispatch rules)++persistentDispatcher :: Int -> Rules -> IO ()+persistentDispatcher port rules = persistentServer port (dispatch rules)
Network/YAML/Instances.hs view
@@ -67,6 +67,30 @@ instance (Default a, Default b, Default c) => Default (a,b,c) where def = (def, def, def) +_right :: BS.ByteString+_right = "Right"++_left :: BS.ByteString+_left = "Left"++instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess (Either a b) YamlObject where+ convertSuccess (Right a) = Mapping [(toYamlScalar _right, cs a)]+ convertSuccess (Left b) = Mapping [(toYamlScalar _left, cs b)]++instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess YamlObject (Either a b) where+ convertSuccess (Mapping [(name, val)]) = + if fromYamlScalar name == _right + then Right (cs val)+ else if fromYamlScalar name == _left+ then Left (cs val)+ else def+ convertSuccess _ = def++instance (Default a) => Default (Either a b) where+ def = Left def++instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (Either a b) where+ instance Default YamlObject where def = Sequence [] @@ -95,6 +119,26 @@ convertSuccess x = Scalar $ toYamlScalar x instance IsYamlObject Integer where++instance IsYamlScalar Bool where+ toYamlScalar True = stringScalar "True"+ toYamlScalar False = stringScalar "False"++ fromYamlScalar x = + case fromYamlScalar x :: String of+ "True" -> True+ _ -> False++instance Default Bool where+ def = False++instance ConvertSuccess Bool YamlObject where+ convertSuccess x = Scalar $ toYamlScalar x++instance ConvertSuccess YamlObject Bool where+ convertSuccess x = fromMaybe def $ getScalar x++instance IsYamlObject Bool where instance ConvertSuccess YamlObject BS.ByteString where convertSuccess x = fromMaybe def $ getScalar x
Network/YAML/Server.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Network.YAML.Server where @@ -30,18 +31,24 @@ -> [BS.ByteString] -- ^ Already read lines -> IO [BS.ByteString] readHandle h acc = do- line <- BS.hGetLine h- 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 readHandle h (acc ++ [line'])+ eof <- hIsEOF h+ if eof+ then return acc+ else do+ line <- BS.hGetLine h+ 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 readHandle h (acc ++ [line']) --- | Start server and wait for connections+-- | Start server and wait for connections.+-- This server closes connection after each query.+-- So, each call is processed in another thread. server :: Int -- ^ Port number -> (YamlObject -> IO YamlObject) -- ^ Worker@@ -66,4 +73,38 @@ res <- callOut ob BS.hPutStrLn h $ serialize res hClose h)++-- | Start server and wait for connections.+-- This server does not close connection after query.+-- So, new thread is created only per-client, not per-query.+persistentServer :: + Int + -> (YamlObject -> IO YamlObject)+ -> IO ()+persistentServer port callOut = do+-- installHandler sigPIPE Ignore Nothing + sock <- listenOn (PortNumber $ fromIntegral port)+ (forever $ loop sock) `finally` sClose sock+ where+ loop :: Socket -> IO ThreadId+ loop sock =+ do (h,_nm,_port) <- accept sock+ forkIO (worker h)++ worker :: Handle -> IO ()+ worker h = do + hSetBuffering h NoBuffering+ lns <- readHandle h []+ let text = BS.unlines lns+ if BS.null text+ then hClose h+ else+ case unserialize text of+ Nothing -> hClose h+ Just ob -> do+ res <- callOut ob+ BS.hPutStrLn h $ serialize res+ if getScalarAttr "connection" ob == Just ("close" :: BS.ByteString)+ then hClose h+ else worker h
Network/YAML/WrapMethods.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Network.YAML.WrapMethods- (remote, declareRules)+ (remote, remote', declareRules, declareRulesWithArg) where import Language.Haskell.TH@@ -28,12 +28,29 @@ (VarI _ tp _ _) <- reify name let AppT (AppT ArrowT a) ioB = tp sequence [- sigD cName [t| (BS.ByteString, Int) -> $(return a) -> $(return ioB) |],+ sigD cName [t| (Connection c) => c -> $(return a) -> $(return ioB) |], funD cName [c]] +-- | Similar to remote, but use it when basic function accepts additional argument,+-- which should not be passed from client.+-- (To be used in pair with declareRulesWithArg).+remote' :: Name -> Q [Dec]+remote' name = do+ srv <- newName "srv"+ let c = clause [varP srv] (normalB [| call $(varE srv) $(stringOfName name) |]) []+ cName = mkName $ nameBase name+ (VarI _ tp _ _) <- reify name+ let AppT (AppT ArrowT _) (AppT (AppT ArrowT a) ioB) = tp+ sequence [+ sigD cName [t| (Connection c) => c -> $(return a) -> $(return ioB) |],+ funD cName [c]]+ rulePair :: Name -> ExpQ rulePair name = [| ($(stringOfName name), yamlMethod $(varE name)) |] +rulePairWithArg :: Name -> Name -> ExpQ+rulePairWithArg arg name = [| ($(stringOfName name), yamlMethod ($(varE name) $(varE arg))) |]+ mkList :: [Exp] -> ExpQ mkList [] = [| [] |] mkList (e:es) = [| $(return e): $(mkList es) |]@@ -49,3 +66,11 @@ sequence [ funD (mkName "dispatchingRules") [c]] +-- | Similar, but pass given arg as first argument to all functions+declareRulesWithArg :: Name -> [Name] -> Q [Dec]+declareRulesWithArg arg names = do+ pairs <- mapM (rulePairWithArg arg) names+ let body = [| mkRules $(mkList pairs) |]+ c = clause [] (normalB body) []+ sequence [+ funD (mkName "dispatchingRules") [c]]
README view
@@ -13,6 +13,14 @@ function deriveIsYamlObject, which will help you to declare `instance IsYamlObject ...' for almost any ADT. +RPC-client calls RPC-methods usually using one of two ways. First is to use+`call' (or `callDynamic') function from Network.YAML.Caller module. One need to+give method name as it's parameter. Second way is to use (TemplateHaskell-)+function `remote' from Network.YAML.WrapMethods module to declare wrapper+functions for RPC-methods. These wrappers will have same names as source+functions, and almost same behaivour. Single difference is that wrappers+require pair: (RPC-server host name, port number) as their first argument.+ You can see examples of usage in files Test.hs and TestCall.hs. Haddock documentation is here: http://iportnov.ru/files/yaml-rpc/html/index.html.
Test.hs view
@@ -17,7 +17,7 @@ main = do putStrLn "Listening..." -- Start 3 listeners on 3 ports- forkA [dispatcher 5000 dispatchingRules,- dispatcher 5001 dispatchingRules,- dispatcher 5002 dispatchingRules]+ forkA [persistentDispatcher 5000 dispatchingRules,+ persistentDispatcher 5001 dispatchingRules,+ persistentDispatcher 5002 dispatchingRules] return ()
TestCall.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, ScopedTypeVariables #-} -- | Test client module Main where +import Control.Monad+import System.Environment (getArgs)+import qualified Data.ByteString.Char8 as BS import Data.Object.Yaml import Data.Convertible.Base @@ -17,31 +20,42 @@ -- For example, `ls' is defined in Methods.hs as -- ls :: String -> IO [String] -- Now `ls' is defined here as--- ls :: (ByteString,Int) -> String -> IO [String]+-- ls :: (Connection c) => c -> String -> IO [String] -rules = [("test", ("127.0.0.1", 5000), 1),- ("test", ("127.0.0.1", 5001), 1),- ("test", ("127.0.0.1", 5002), 1)] -getService = selectRandom rules+rules host = [("test", (host', 5000), 1),+ ("test", (host', 5001), 1),+ ("test", (host', 5002), 1)]+ where+ host' = BS.pack host +getService host = selectRandom (rules host)+ p = Point 2.0 3.0 ps = [Point 3.0 5.0, Point 1.0 2.1, Point 0.1 0.2] main = do- test <- getService "test"+ [host] <- getArgs+ test <- getService host "test" + (conn :: PersistentConnection) <- newConnection test+-- (conn :: HostAndPort) <- newConnection test+ -- call remote functions- r <- double test p- print r- s <- mySum test [3.5, 5.5, 1.0]- print s- lst <- ls test "/tmp"- print lst+ replicateM 100 $ do+ r <- double conn p+ print r - -- call remote functions for many arguments, for each argument on different server maybe- rs <- callP getService "test" "double" ps- print (rs :: [Point])- cs <- callP getService "test" "counter" $ zip ([3,4,5,6] :: [Int]) ([1..] :: [Int])- print (cs :: [Int])+-- s <- mySum conn [3.5, 5.5, 1.0]+-- print s+-- lst <- ls conn "/tmp"+-- print lst+-- +-- -- call remote functions for many arguments, for each argument on different server maybe+-- rs <- callP (getService host) "test" "double" ps+-- print (rs :: [Point])+-- cs <- callP (getService host) "test" "counter" $ zip ([3,4,5,6] :: [Int]) ([1..] :: [Int])+-- print (cs :: [Int])++ closeConnection conn
yaml-rpc.cabal view
@@ -3,7 +3,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1+Version: 0.2 -- A short (one-line) description of the package. Synopsis: Simple library for network (TCP/IP) YAML RPC