yaml-rpc (empty) → 0.1
raw patch · 15 files changed
+947/−0 lines, 15 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, convertible-text, data-default, data-object, data-object-yaml, mtl, network, random, template-haskell, yaml
Files
- LICENSE +165/−0
- Network/YAML.hs +20/−0
- Network/YAML/Balancer.hs +19/−0
- Network/YAML/Base.hs +78/−0
- Network/YAML/Caller.hs +82/−0
- Network/YAML/Derive.hs +127/−0
- Network/YAML/Dispatcher.hs +31/−0
- Network/YAML/Instances.hs +145/−0
- Network/YAML/Server.hs +69/−0
- Network/YAML/WrapMethods.hs +51/−0
- README +20/−0
- Setup.hs +2/−0
- Test.hs +23/−0
- TestCall.hs +47/−0
- yaml-rpc.cabal +68/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions. ++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version. ++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Network/YAML.hs view
@@ -0,0 +1,20 @@++module Network.YAML + (+ module Network.YAML.Caller,+ module Network.YAML.Instances,+ module Network.YAML.Derive,+ module Network.YAML.Dispatcher,+ module Network.YAML.Balancer,+ module Network.YAML.WrapMethods,+ forkA+ ) where++import Network.YAML.Caller+import Network.YAML.Instances+import Network.YAML.Derive+import Network.YAML.Dispatcher+import Network.YAML.Balancer+import Network.YAML.WrapMethods +import Network.YAML.Server (forkA)+
+ Network/YAML/Balancer.hs view
@@ -0,0 +1,19 @@++module Network.YAML.Balancer where++import System.Random+import qualified Data.ByteString.Char8 as BS++type Server = (BS.ByteString, Int)++-- | Select random server+selectRandom :: [(BS.ByteString, Server, Int)] -- ^ [(Service name, (hostname, port number), priority)]+ -> BS.ByteString -- ^ Service name+ -> IO Server+selectRandom lst service = do+ let lst' = concatMap (\(name,srv,p) -> replicate p (name, srv)) lst+ lst'' = map snd $ filter (\(name,srv) -> name==service) lst'+ n = length lst''+ k <- randomRIO (0, n-1)+ return $ lst'' !! k+
+ Network/YAML/Base.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-}++module Network.YAML.Base where++import Control.Monad+import Data.Maybe+import Data.Default+import Data.Object+import Data.Object.Yaml+import qualified Data.ByteString.Char8 as BS+import Text.Libyaml hiding (encode, decode)++class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject, Default a) => IsYamlObject a where++getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject+getAttr key (Mapping pairs) = lookup (toYamlScalar key) pairs+getAttr key (Sequence lst) =+ case catMaybes $ map (getAttr key) lst of+ [x] -> Just x+ _ -> Nothing+getAttr key (Scalar sc) = Nothing++getScalar :: (IsYamlScalar a) => YamlObject -> Maybe a +getScalar (Scalar x) = Just (fromYamlScalar x)+getScalar _ = Nothing++getList :: YamlObject -> [YamlObject]+getList (Sequence lst) = lst+getList _ = []++getScalarAttr :: (IsYamlScalar a) => BS.ByteString -> YamlObject -> Maybe a+getScalarAttr key obj = getScalar =<< getAttr key obj++getSubKey :: (IsYamlScalar a) => BS.ByteString -> BS.ByteString -> YamlObject -> Maybe a+getSubKey key subkey obj = do+ attr <- getAttr key obj+ r <- getAttr subkey attr+ getScalar r++getItem :: BS.ByteString -> Int -> YamlObject -> YamlObject+getItem key k obj = + case getListAttr key obj of+ [] -> Sequence []+ lst -> lst !! k++getListAttr :: BS.ByteString -> YamlObject -> [YamlObject]+getListAttr key obj = + case getAttr key obj of+ Just x -> getList x+ Nothing -> []++getFirstKey :: YamlObject -> BS.ByteString+getFirstKey (Mapping pairs) = fromYamlScalar $ fst $ head pairs++instance IsYamlScalar Double where+ fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v+ toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any++instance IsYamlScalar Int where+ fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v+ toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any++instance IsYamlScalar Integer where+ fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v+ toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any++serialize :: IsYamlObject a => a -> BS.ByteString+serialize x = + let c :: YamlObject+ c = cs x+ in encode c++unserialize :: IsYamlObject a => BS.ByteString -> Maybe a+unserialize x =+ let d :: Maybe YamlObject+ d = decode x+ in cs `fmap` d+
+ Network/YAML/Caller.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.YAML.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 Control.Monad+import Control.Concurrent++import Network.YAML.Base+import Network.YAML.Instances+import Network.YAML.Server++-- | Send any YAML text and return an answer+sendYAML :: (BS.ByteString, Int) -- ^ (Hostname, port)+ -> BS.ByteString -- ^ YAML text+ -> IO BS.ByteString -- ^ Answer+sendYAML (host,port) yaml = withSocketsDo $ do+ h <- connectTo (BS.unpack host) (PortNumber $ fromIntegral port)+ hSetBuffering h NoBuffering+ BS.hPutStrLn h yaml+ lns <- readHandle h []+ hClose h+ 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++-- | Similar, 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+ -> BS.ByteString -- ^ Name of method+ -> a -- ^ Argument for method+ -> IO b+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+-- putStrLn $ "Calling to " ++ show srv+ 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+
+ Network/YAML/Derive.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.YAML.Derive+ (deriveDefault, deriveIsYamlObject,+ stringOfName)+ where++import Language.Haskell.TH+import Control.Monad+import Data.Maybe+import Data.Default+import Data.Object+import Data.Object.Yaml+import qualified Data.ByteString.Char8 as BS++import Network.YAML.Base++mkList :: [Name] -> ExpQ+mkList [] = [| [] |]+mkList (v:vars) = [| (toYamlScalar $(stringOfName v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |]++mkSeq :: [Name] -> ExpQ+mkSeq [] = [| [] |]+mkSeq (v:vars) = [| cs $(varE v): $(mkSeq vars) |]++getNameBase :: Name -> Name+getNameBase name = mkName $ nameBase name++stringOfName :: Name -> ExpQ+stringOfName n = sigE (stringE $ nameBase n) [t| BS.ByteString |]++nameE :: Name -> ExpQ+nameE name = varE $ getNameBase name++consClause :: Con -> ClauseQ+consClause (NormalC name fields) = do+ -- Name of constructor, i.e. "A". Will become string literal in generated code+ let constructorName = nameBase name++ -- Get variables for left and right side of function definition+ (pats,vars) <- genPE (length fields)++ clause [conP name pats] -- (A x1 x2)+ (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Sequence $(mkSeq vars))] |]) []++consClause (RecC name fields) = do+ -- Name of constructor, i.e. "A". Will become string literal in generated code+ let constructorName = nameBase name+ names = [getNameBase name | (name, _, _) <- fields]+ pats = map varP names+ clause [conP name pats] -- (A x1 x2)+ (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList names))] |]) []++consClause x = report True (show x) >> return undefined++genFromClause cName names= do+ obj <- newName "obj"+ let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |]+ body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map getNameBase names+ clause [varP obj] (guardedB [normalGE guard body]) []+ where+ getAttr' c obj n = [| fromMaybe def $ getSubKey (BS.pack c) $(stringOfName n) $(varE obj) |]++fromClause :: Con -> ClauseQ+fromClause (RecC name fields) = do+ let constructorName = nameBase name+ names = [getNameBase name | (name, _, _) <- fields]+ genFromClause constructorName names++fromClause (NormalC name fields) = do+ let cName = nameBase name+ (_,names) <- genPE (length fields)+ obj <- newName "obj"+ let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |]+ 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) |]+ 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]]++-- | 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]]++-- | 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]++defaultClause :: Con -> ClauseQ+defaultClause (RecC name fields) = do+ let defs = replicate (length fields) (varE $ mkName "def")+ body = foldl appE (conE name) defs+ clause [] (normalB body) []+defaultClause (NormalC name fields) = do+ let defs = replicate (length fields) (varE $ mkName "def")+ body = foldl appE (conE name) defs+ clause [] (normalB body) []++-- | Derive `instance Default t where def = ...'+deriveDefault :: Name -> Q [Dec]+deriveDefault t = do+ TyConI (DataD _ _ _ constructors _) <- reify t+ body <- defaultClause (head constructors)+ return [InstanceD [] (ConT ''Default `AppT` ConT t) [FunD 'def [body]]]++-- | Generate n unique variables and return them in form of patterns and expressions+genPE :: Int -> Q ([PatQ], [Name])+genPE n = do+ ids <- replicateM n (newName "x")+ return (map varP ids, ids)+
+ Network/YAML/Dispatcher.hs view
@@ -0,0 +1,31 @@++module Network.YAML.Dispatcher where++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.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 pairs = M.fromList pairs++-- | Select worker from dispatching rules+dispatch :: Rules -> Worker+dispatch rules = \obj -> + let call :: Call+ call = cs obj+ in case M.lookup (methodName call) rules of+ Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call)+ Just fn -> fn (args call)++-- | Listens given port and dispatches requests+dispatcher :: Int -> Rules -> IO ()+dispatcher port rules = server port (dispatch rules)
+ Network/YAML/Instances.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings, FlexibleInstances, IncoherentInstances #-}++module Network.YAML.Instances where+ +import Data.Maybe+import Data.Default+import Data.Object+import Data.Object.Yaml+import qualified Data.ByteString.Char8 as BS++import Network.YAML.Base++-- | Build YamlObject from (key,value) pairs+object :: [(BS.ByteString, YamlScalar)] -> YamlObject+object pairs = Mapping [(toYamlScalar name, Scalar val) | (name,val) <- pairs]++-- | Build YamlObject with single field+field :: (IsYamlScalar a) => BS.ByteString -> a -> YamlObject+field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)]++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++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) => ConvertSuccess YamlObject (a,b) where+ convertSuccess obj = (cs x, cs 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) => ConvertSuccess YamlObject (a,b,c) where+ convertSuccess obj = (cs x, cs y, cs 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)++instance (Default a, Default b, Default c) => Default (a,b,c) where+ def = (def, def, 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++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++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++instance IsYamlObject Integer where++instance ConvertSuccess YamlObject BS.ByteString where+ convertSuccess x = fromMaybe def $ getScalar x++instance ConvertSuccess BS.ByteString YamlObject where+ convertSuccess x = Scalar $ toYamlScalar 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++instance IsYamlObject String where++data Call = Call { methodName :: BS.ByteString, args :: YamlObject }+ deriving (Show)++mkCall :: BS.ByteString -> YamlObject -> YamlObject+mkCall name args = cs $ 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++-- | 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+ y <- fn x+ return $ cs y+
+ Network/YAML/Server.hs view
@@ -0,0 +1,69 @@++module Network.YAML.Server where++import Control.Monad +import Control.Monad.State+import Control.Concurrent+import Control.Exception+import Network+import System.IO+import qualified Data.ByteString.Char8 as BS+import Data.Object.Yaml++import Network.YAML.Base+import Network.YAML.Instances++-- | Run each IO action in separate thread and return all results+forkA :: [IO a] -> IO [a]+forkA lst = do+ let n = length lst+ vars <- replicateM n newEmptyMVar+ mapM (forkIO . run) $ zip lst vars+ mapM takeMVar vars+ where+ run (x,v) = do+ r <- x+ putMVar v r++-- | Read lines from Handle+readHandle :: Handle+ -> [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'])++-- | Start server and wait for connections+server ::+ Int -- ^ Port number+ -> (YamlObject -> IO YamlObject) -- ^ Worker+ -> IO ()+server 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+ (do + 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.hPutStrLn h $ serialize res+ hClose h)+
+ Network/YAML/WrapMethods.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}++module Network.YAML.WrapMethods+ (remote, declareRules)+ where++import Language.Haskell.TH+import Control.Monad+import Data.Char (toUpper)+import Data.Object.Yaml+import qualified Data.ByteString.Char8 as BS++import Network.YAML.Base+import Network.YAML.Caller+import Network.YAML.Derive+import Network.YAML.Instances+import Network.YAML.Dispatcher++-- | Declare given function as remote method. +-- This creates a function with same name as given (so qualified name must be+-- used as argument), and almost same behaivour. Difference is that newly+-- declared function takes pair (host name, port number) as first argument.+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 a) ioB = tp+ sequence [+ sigD cName [t| (BS.ByteString, Int) -> $(return a) -> $(return ioB) |],+ funD cName [c]]++rulePair :: Name -> ExpQ+rulePair name = [| ($(stringOfName name), yamlMethod $(varE name)) |]++mkList :: [Exp] -> ExpQ+mkList [] = [| [] |]+mkList (e:es) = [| $(return e): $(mkList es) |]++-- | Declare dispatching rules for given list of functions. +-- Map with rules will be called dispatchingRules.+-- For each given function RPC method with same name will be declared.+declareRules :: [Name] -> Q [Dec]+declareRules names = do+ pairs <- mapM rulePair names+ let body = [| mkRules $(mkList pairs) |]+ c = clause [] (normalB body) []+ sequence [+ funD (mkName "dispatchingRules") [c]]+
+ README view
@@ -0,0 +1,20 @@+YAML-RPC README+===============+Ilya V. Portnov <portnov84@rambler.ru>++The yaml-rpc package contains a small library to organize remote procedure call+(RPC) over TCP/IP network, using YAML as data serialization format.++RPC server should supply a set of "RPC methods", which are simply functions ::+a -> IO b, `a' and 'b' should be of class IsYamlObject. This class guarantees+that values of given type can be serialized to YAML and de-serialized.+Network.YAML.Instances module provides some instances declaration for this+typeclass. Moreover, Network.YAML.Derive module contains (TemplateHaskell)+function deriveIsYamlObject, which will help you to declare `instance+IsYamlObject ...' for almost any ADT.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+-- | Test server+module Main where++import Data.Object.Yaml+import Data.Convertible.Base+import qualified Data.Map as M++import Network.YAML++import TestTypes+import Methods++-- Declare dispatchingRules for given functions+$(declareRules ['double, 'mySum, 'counter, 'ls])++main = do+ putStrLn "Listening..."+ -- Start 3 listeners on 3 ports+ forkA [dispatcher 5000 dispatchingRules,+ dispatcher 5001 dispatchingRules,+ dispatcher 5002 dispatchingRules]+ return ()
+ TestCall.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+-- | Test client+module Main where++import Data.Object.Yaml+import Data.Convertible.Base++import Network.YAML++import TestTypes+import qualified Methods++-- declare `double', `mySum' and `ls' as RPC methods+$(remote 'Methods.double)+$(remote 'Methods.mySum)+$(remote 'Methods.ls)+-- 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]++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++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"++ -- 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++ -- 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])
+ yaml-rpc.cabal view
@@ -0,0 +1,68 @@+Name: yaml-rpc++-- 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++-- A short (one-line) description of the package.+Synopsis: Simple library for network (TCP/IP) YAML RPC++-- A longer description of the package.+Description: This library aimed to organize remote procedure call (RPC) + over TCP/IP network, using YAML as data serialization format.++-- URL for the project homepage or repository.+Homepage: http://iportnov.ru/en/projects/yaml-rpc-0/++-- The license under which the package is released.+License: LGPL-3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Ilya V. Portnov++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: portnov84@rambler.ru++-- A copyright notice.+-- Copyright: ++Category: Network++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: README Test.hs TestCall.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.4+++Library+ -- Modules exported by the library.+ Exposed-modules: Network.YAML.Derive,+ Network.YAML.Server,+ Network.YAML.Caller,+ Network.YAML.Dispatcher,+ Network.YAML.Instances,+ Network.YAML.Base,+ Network.YAML.WrapMethods,+ Network.YAML.Balancer,+ Network.YAML+ + -- 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,+ containers, random+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +