packages feed

yaml-rpc 0.2 → 0.3

raw patch · 13 files changed

+123/−133 lines, 13 filesdep −convertible-text

Dependencies removed: convertible-text

Files

Network/YAML.hs view
@@ -1,17 +1,17 @@  module Network.YAML    (+   module Network.YAML.Types,    module Network.YAML.Caller,    module Network.YAML.Instances,    module Network.YAML.Derive,    module Network.YAML.Dispatcher,    module Network.YAML.Balancer,    module Network.YAML.WrapMethods,-   HostAndPort,    forkA   ) where -import Network.YAML.Base (HostAndPort)+import Network.YAML.Types import Network.YAML.Caller import Network.YAML.Instances import Network.YAML.Derive
Network/YAML/Balancer.hs view
@@ -4,7 +4,7 @@ import System.Random import qualified Data.ByteString.Char8 as BS -import Network.YAML.Base (HostAndPort)+import Network.YAML.Types  -- | Select random server selectRandom :: [(BS.ByteString, HostAndPort, Int)]   -- ^ [(Service name, (hostname, port number), priority)]
Network/YAML/Base.hs view
@@ -10,9 +10,7 @@ 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+import Network.YAML.Types  getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject getAttr key (Mapping pairs) = lookup (toYamlScalar key) pairs@@ -69,12 +67,12 @@ serialize :: IsYamlObject a => a -> BS.ByteString serialize x =    let c :: YamlObject-      c = cs x+      c = toYaml x   in  encode c  unserialize :: IsYamlObject a => BS.ByteString -> Maybe a unserialize x =   let d :: Maybe YamlObject       d = decode x-  in  cs `fmap` d+  in  fromYaml `fmap` d
Network/YAML/Caller.hs view
@@ -1,30 +1,25 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} -module Network.YAML.Caller where+module Network.YAML.Caller+  (callDynamic,+   callF,+   callP+  )+  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 Control.Monad import Control.Concurrent -import Network.YAML.Base+import Network.YAML.Types+import Network.YAML.Base (serialize, unserialize) 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@@ -57,7 +52,7 @@ --        -> a                               -- ^ Argument for method --        -> IO b   call (host,port) name args = do-    let c = mkCall name (cs args)+    let c = mkCall name (toYaml args)         s = serialize c     text <- sendYAML (host,port) s     case unserialize text of@@ -67,8 +62,6 @@   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)@@ -77,7 +70,7 @@   closeConnection (PC h) = hClose h    call (PC h) name args = do-    let c = mkCall name (cs args)+    let c = mkCall name (toYaml args)         s = serialize c     text <- hSendYAML h s     case unserialize text of
Network/YAML/Derive.hs view
@@ -13,6 +13,7 @@ import Data.Object.Yaml import qualified Data.ByteString.Char8 as BS +import Network.YAML.Types import Network.YAML.Base  mkList :: [Name] -> ExpQ@@ -21,7 +22,7 @@  mkSeq :: [Name] -> ExpQ mkSeq []       = [| [] |]-mkSeq (v:vars) = [| cs $(varE v): $(mkSeq vars) |]+mkSeq (v:vars) = [| toYaml $(varE v): $(mkSeq vars) |]  getNameBase :: Name -> Name getNameBase name = mkName $ nameBase name@@ -75,32 +76,30 @@         body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map fst (zip [0..] names)     clause [varP obj] (guardedB [normalGE guard body]) []   where-    getAttr' c obj k = [| cs $ getItem (BS.pack c) k $(varE obj) |]+    getAttr' c obj k = [| fromYaml $ getItem (BS.pack c) k $(varE obj) |]     getName (n,x) = (n, getNameBase x)      --- | Derive `instance ConvertSuccess t YamlObject ...' deriveToYamlObject :: Name -> Q [Dec] deriveToYamlObject t = do   -- Get list of constructors for type t   TyConI (DataD _ _ _ constructors _)  <-  reify t   convbody <- mapM consClause constructors-  return [InstanceD [] (ConT ''ConvertSuccess `AppT` ConT t `AppT` ConT ''YamlObject) [FunD 'convertSuccess convbody]]+  return [FunD 'toYaml convbody] --- | Derive `instance ConvertSuccess YamlObject t ...' deriveFromYamlObject :: Name -> Q [Dec] deriveFromYamlObject t = do   TyConI (DataD _ _ _ constructors _)  <-  reify t   body <- mapM fromClause constructors-  return [InstanceD [] (ConT ''ConvertSuccess `AppT` ConT ''YamlObject `AppT` ConT t) [FunD 'convertSuccess body]]+  return [FunD 'fromYaml body]  -- | Derive `instance IsYamlObject t where ...' deriveIsYamlObject :: Name -> Q [Dec] deriveIsYamlObject t = do   [i1] <- deriveToYamlObject t   [i2] <- deriveFromYamlObject t-  let i3 = InstanceD [] (ConT ''IsYamlObject `AppT` ConT t) []-  return [i1,i2,i3]+  let res = InstanceD [] (ConT ''IsYamlObject `AppT` ConT t) [i1, i2]+  return [res]  defaultClause :: Con -> ClauseQ defaultClause (RecC name fields) = do
Network/YAML/Dispatcher.hs view
@@ -3,25 +3,21 @@  import qualified Data.Map as M import Data.Object.Yaml-import Data.Convertible.Base import qualified Data.ByteString.Char8 as BS -import Network.YAML.Base+import Network.YAML.Types import Network.YAML.Instances import Network.YAML.Server -type Worker = YamlObject -> IO YamlObject-type Rules = M.Map BS.ByteString Worker- -- | Build dispatching rules-mkRules :: [(BS.ByteString,Worker)] -> Rules+mkRules :: [(BS.ByteString, Worker)] -> Rules mkRules pairs = M.fromList pairs  -- | Select worker from dispatching rules dispatch :: Rules -> Worker dispatch rules = \obj ->    let call :: Call-      call = cs obj+      call = fromYaml obj   in case M.lookup (methodName call) rules of       Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call)       Just fn -> fn (args call)@@ -30,5 +26,6 @@ dispatcher :: Int -> Rules -> IO () dispatcher port rules = server port (dispatch rules) +-- | Similar, but use persistent server. persistentDispatcher :: Int -> Rules -> IO () persistentDispatcher port rules = persistentServer port (dispatch rules)
Network/YAML/Instances.hs view
@@ -8,6 +8,7 @@ import Data.Object.Yaml import qualified Data.ByteString.Char8 as BS +import Network.YAML.Types import Network.YAML.Base  -- | Build YamlObject from (key,value) pairs@@ -21,46 +22,37 @@ instance Default BS.ByteString where   def = BS.empty -instance (IsYamlObject a) => ConvertSuccess [a] YamlObject where-  convertSuccess lst = Sequence $ map cs lst--instance (IsYamlObject a) => ConvertSuccess YamlObject [a] where-  convertSuccess (Mapping pairs) = map cs $ map snd pairs-  convertSuccess (Sequence lst) = map cs lst-  convertSuccess s@(Scalar _) = [cs s]- instance (IsYamlObject a) => IsYamlObject [a] where+  toYaml lst = Sequence $ map toYaml lst +  fromYaml (Mapping pairs) = map fromYaml $ map snd pairs+  fromYaml (Sequence lst) = map fromYaml lst+  fromYaml s@(Scalar _) = [fromYaml s]+ tryGet lst k =    if k >= length lst     then def     else lst !! k -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess (a,b) YamlObject where-  convertSuccess (x,y) = Sequence [cs x, cs y]+instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (a,b) where+  toYaml (x,y) = Sequence [toYaml x, toYaml y] -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess YamlObject (a,b) where-  convertSuccess obj = (cs x, cs y) +  fromYaml obj = (fromYaml x, fromYaml y)      where       list = getList obj       x = tryGet list 0       y = tryGet list 1 -instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (a,b) where--instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => ConvertSuccess (a,b,c) YamlObject where-  convertSuccess (x,y,z) = Sequence [cs x, cs y, cs z]+instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => IsYamlObject (a,b,c) where+  toYaml (x,y,z) = Sequence [toYaml x, toYaml y, toYaml z] -instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => ConvertSuccess YamlObject (a,b,c) where-  convertSuccess obj = (cs x, cs y, cs z) +  fromYaml obj = (fromYaml x, fromYaml y, fromYaml z)      where       list = getList obj       x = tryGet list 0       y = tryGet list 1       z = tryGet list 2 -instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => IsYamlObject (a,b,c) where- instance (Default a, Default b) => Default (a,b) where   def = (def, def) @@ -73,52 +65,39 @@ _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+  toYaml (Right a) = Mapping [(toYamlScalar _right, toYaml a)]+  toYaml (Left b) = Mapping [(toYamlScalar _left, toYaml b)] +  fromYaml (Mapping [(name, val)]) = +    if fromYamlScalar name == _right +      then Right (fromYaml val)+      else if fromYamlScalar name == _left+             then Left (fromYaml val)+             else def+  fromYaml _ = def+ instance Default YamlObject where   def = Sequence []  instance IsYamlObject YamlObject where--instance ConvertSuccess YamlObject Double where-  convertSuccess x = fromMaybe def $ getScalar x--instance ConvertSuccess Double YamlObject where-  convertSuccess x = Scalar $ toYamlScalar x+  toYaml = id+  fromYaml = id  instance IsYamlObject Double where--instance ConvertSuccess YamlObject Int where-  convertSuccess x = fromMaybe def $ getScalar x--instance ConvertSuccess Int YamlObject where-  convertSuccess x = Scalar $ toYamlScalar x+  fromYaml x = fromMaybe def $ getScalar x+  toYaml x = Scalar $ toYamlScalar x  instance IsYamlObject Int where--instance ConvertSuccess YamlObject Integer where-  convertSuccess x = fromMaybe def $ getScalar x--instance ConvertSuccess Integer YamlObject where-  convertSuccess x = Scalar $ toYamlScalar x+  fromYaml x = fromMaybe def $ getScalar x+  toYaml x = Scalar $ toYamlScalar x  instance IsYamlObject Integer where+  fromYaml x = fromMaybe def $ getScalar x+  toYaml x = Scalar $ toYamlScalar x  instance IsYamlScalar Bool where   toYamlScalar True = stringScalar "True"@@ -132,58 +111,39 @@ 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--instance ConvertSuccess BS.ByteString YamlObject where-  convertSuccess x = Scalar $ toYamlScalar x+  toYaml x = Scalar $ toYamlScalar x+  fromYaml x = fromMaybe def $ getScalar x  instance IsYamlObject BS.ByteString where--instance ConvertSuccess YamlObject String where-  convertSuccess x = fromMaybe def $ getScalar x--instance ConvertSuccess String YamlObject where-  convertSuccess x = Scalar $ toYamlScalar x+  fromYaml x = fromMaybe def $ getScalar x+  toYaml x = Scalar $ toYamlScalar x  instance IsYamlObject String where--data Call = Call { methodName :: BS.ByteString, args :: YamlObject }-  deriving (Show)+  fromYaml x = fromMaybe def $ getScalar x+  toYaml x = Scalar $ toYamlScalar x  mkCall :: BS.ByteString -> YamlObject -> YamlObject-mkCall name args = cs $ Call name args+mkCall name args = toYaml $ Call name args  stringScalar :: String -> YamlScalar stringScalar = toYamlScalar -instance ConvertSuccess Call YamlObject where-  convertSuccess (Call name args) = Mapping [(stringScalar "call", Scalar $ toYamlScalar name), -                                             (stringScalar "args", args)]--instance ConvertSuccess YamlObject Call where-  convertSuccess obj = Call name args-    where-      name = fromMaybe "defaultMethod" $ getScalarAttr "call" obj-      args = fromMaybe (Sequence []) $ getAttr "args" obj- instance Default Call where   def = Call "defaultMethod" def  instance IsYamlObject Call where+  toYaml (Call name args) = Mapping [(stringScalar "call", Scalar $ toYamlScalar name), +                                             (stringScalar "args", args)]+  fromYaml obj = Call name args+    where+      name = fromMaybe "defaultMethod" $ getScalarAttr "call" obj+      args = fromMaybe (Sequence []) $ getAttr "args" obj  -- | Convert any (a -> IO b) action to YAML RPC method yamlMethod :: (IsYamlObject a, IsYamlObject b) => (a -> IO b) -> YamlObject -> IO YamlObject yamlMethod fn = \obj -> do-  let x = cs obj+  let x = fromYaml obj   y <- fn x-  return $ cs y+  return $ toYaml y
Network/YAML/Server.hs view
@@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Object.Yaml +import Network.YAML.Types import Network.YAML.Base import Network.YAML.Instances @@ -51,7 +52,7 @@ -- So, each call is processed in another thread. server ::       Int                              -- ^ Port number-   -> (YamlObject -> IO YamlObject)    -- ^ Worker+   -> Worker    -> IO () server port callOut = do --        installHandler sigPIPE Ignore Nothing    @@ -79,7 +80,7 @@ -- So, new thread is created only per-client, not per-query. persistentServer ::        Int -   -> (YamlObject -> IO YamlObject)+   -> Worker    -> IO () persistentServer port callOut = do --        installHandler sigPIPE Ignore Nothing
Network/YAML/WrapMethods.hs view
@@ -10,7 +10,7 @@ import Data.Object.Yaml import qualified Data.ByteString.Char8 as BS -import Network.YAML.Base+import Network.YAML.Types import Network.YAML.Caller import Network.YAML.Derive import Network.YAML.Instances
README view
@@ -21,8 +21,52 @@ functions, and almost same behaivour. Single difference is that wrappers require pair: (RPC-server host name, port number) as their first argument. +Two modes of communication are supported. In first mode, client and server act+as following:++  Client:+    - opens socket to server+    - writes query to socket+    - waits for answer and reads it+    - closes socket+    - for next query, opens socket again etc.+  Server:+    - listens on socket+    - on connection (in the separate thread):+      - reads a query+      - computes answer+      - writes answer to socket+      - closes socket.++So, first mode is `one connection per query' mode. It's designed for situations+when network connection between clients and servers is pretty good, and many+machines runs same server code. So, this mode of RPC can be used in parallel+load-balancing clusters.++In second mode, client and server act as following:++  Client:+    - opens socket to server+    - writers query to socket+    - waits for answer and reads it+    - writes next query+    - reads next answer+    - etc+    - closes socket+  Server:+    - listens on socket+    - on connection (in separate thread):+      - reads a query+      - writes answer to socket+      - reads next query+      - etc++So, second mode is `one connection for series of queries', or 'persistent+connection' mode. It's designed for situations when opening a socket takes much+time — for example, when connection between client and server is not so good.+ 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.  Depends: ghc >= 6.10, network, data-object, data-object-yaml, yaml,-data-default, convertible-text.+data-default.
Test.hs view
@@ -3,7 +3,6 @@ module Main where  import Data.Object.Yaml-import Data.Convertible.Base import qualified Data.Map as M  import Network.YAML
TestCall.hs view
@@ -6,7 +6,6 @@ import System.Environment (getArgs) import qualified Data.ByteString.Char8 as BS import Data.Object.Yaml-import Data.Convertible.Base  import Network.YAML
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.2+Version:             0.3  -- A short (one-line) description of the package. Synopsis:            Simple library for network (TCP/IP) YAML RPC@@ -57,7 +57,7 @@      -- Packages needed in order to build this package.   Build-depends:       yaml, data-object-yaml, network, template-haskell, bytestring,-                       data-object, data-default, base >= 3 && <= 5, mtl, convertible-text,+                       data-object, data-default, base >= 3 && <= 5, mtl,                         containers, random      -- Modules not exported by this package.