yaml-rpc 0.3.1 → 1.0
raw patch · 21 files changed
+617/−1043 lines, 21 filesdep +aesondep +http-clientdep +http-typesdep −data-defaultdep −data-objectdep −data-object-yamldep ~bytestring
Dependencies added: aeson, http-client, http-types, lens, text, th-lift, transformers, unordered-containers, vector, wreq
Dependencies removed: data-default, data-object, data-object-yaml, mtl, network, random
Dependency ranges changed: bytestring
Files
- LICENSE +24/−159
- Network/YAML.hs +8/−14
- Network/YAML/API.hs +139/−0
- Network/YAML/Balancer.hs +0/−19
- Network/YAML/Base.hs +0/−78
- Network/YAML/Caller.hs +29/−111
- Network/YAML/Derive.hs +0/−126
- Network/YAML/Dispatcher.hs +0/−31
- Network/YAML/Instances.hs +0/−143
- Network/YAML/Server.hs +0/−111
- Network/YAML/TH/Client.hs +82/−0
- Network/YAML/TH/Dispatcher.hs +69/−0
- Network/YAML/TH/Server.hs +122/−0
- Network/YAML/WrapMethods.hs +0/−76
- README +0/−72
- README.md +59/−0
- Test.hs +0/−22
- Test/Client.hs +32/−0
- Test/TestAPI.hs +16/−0
- TestCall.hs +0/−60
- yaml-rpc.cabal +37/−21
LICENSE view
@@ -1,165 +1,30 @@- 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:+Copyright (c) 2012, IlyaPortnov - 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.+All rights reserved. - 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.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: - 6. Revised Versions of the GNU Lesser General Public License.+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. - 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.+ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution. - 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.+ * Neither the name of IlyaPortnov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission. - 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.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Network/YAML.hs view
@@ -1,22 +1,16 @@ module Network.YAML (- module Network.YAML.Types,+ module Network.YAML.API, 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+ module Network.YAML.TH.Server,+ module Network.YAML.TH.Client,+ module Network.YAML.TH.Dispatcher ) where -import Network.YAML.Types+import Network.YAML.API 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)+import Network.YAML.TH.Server+import Network.YAML.TH.Client+import Network.YAML.TH.Dispatcher
+ Network/YAML/API.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}+module Network.YAML.API+ (Type (..), Method (..), API (..),+ readAPI+ ) where++import Control.Monad+import Data.Char+import Data.Yaml+import qualified Data.ByteString as B+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.HashMap.Strict as H+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Lift++instance (Lift a, Lift b) => Lift (M.Map a b) where+ lift m = [| M.fromList $ $(lift list) |]+ where list = M.assocs m++instance Lift T.Text where+ lift text = [| T.pack $(lift str) |]+ where str = T.unpack text++-- | Data type description for API+data Type =+ TVoid -- ^ Like (); YAML notation for it is Void.+ | TString+ | TText+ | TInteger+ | TDouble+ | TList Type -- ^ @[Type]@. YAML notation is @List Type@.+ | TUser (M.Map T.Text Type) -- ^ User-defined record type+ | THaskell T.Text -- ^ Any Haskell type+ deriving (Eq, Show)++$(deriveLift ''Type)++-- | API method description+data Method = Method {+ methodArgs :: [Type] -- ^ Types of method arguments+ , methodReturnType :: Type -- ^ Method return value type+ } deriving (Eq, Show)++$(deriveLift ''Method)++-- | API description+data API = API {+ apiUri :: T.Text -- ^ API service identification+ , apiTypes :: M.Map T.Text Type -- ^ Exposed data types+ , apiMethods :: M.Map T.Text Method -- ^ Exposed methods+ } deriving (Eq, Show)++$(deriveLift ''API)++instance FromJSON Type where+ parseJSON (String "Void") = return TVoid+ parseJSON (String "String") = return TString+ parseJSON (String "Text") = return TText+ parseJSON (String "Integer") = return TInteger+ parseJSON (String "Double") = return TDouble+ parseJSON (String text) = do+ let lst = filter (not . T.null) $ T.split isSpace text+ if (length lst == 2) && (head lst == "List")+ then TList `fmap` parseJSON (String $ lst !! 1)+ else return (THaskell text)+ parseJSON x@(Object v) = do+ typeFields <- parseJSON x+ return $ TUser typeFields+ parseJSON x = fail $ "Invalid type description: " ++ show x++instance FromJSON Method where+ parseJSON (Object v) = do+ returnType <- v .:? "return" .!= TVoid+ args <- v .:? "arguments" .!= []+ return $ Method args returnType+ parseJSON x = fail $ "Invalid method description: " ++ show x++resolveType :: M.Map T.Text Type -> Type -> Type+resolveType types t@(THaskell name) =+ case M.lookup name types of+ Just result -> result+ Nothing -> t+resolveType _ t = t++resolveMethodTypes :: M.Map T.Text Type -> Method -> Method+resolveMethodTypes types (Method args returnType) =+ let args' = map (resolveType types) args+ returnType' = resolveType types returnType+ in Method args' returnType'++instance FromJSON API where+ parseJSON (Object v) = do+ uri <- v .: "uri"+ types <- v .:? "types" .!= M.empty+ methods <- v .:? "methods" .!= M.empty+ return $ API uri types methods+ parseJSON x = fail $ "Invalid API description: " ++ show x++instance ToJSON Type where+ toJSON TVoid = String "Void"+ toJSON TString = String "String"+ toJSON TText = String "Text"+ toJSON TInteger = String "Integer"+ toJSON TDouble = String "Double"+ toJSON (TList t) = case toJSON t of+ String s -> String $ "List " `T.append` s+ x -> error $ "Unsupported inner type for List: " ++ show x+ toJSON (TUser fields) = Object $ H.fromList [(name, toJSON t) | (name, t) <- M.assocs fields]+ toJSON (THaskell name) = String name++instance ToJSON Method where+ toJSON (Method args returnType) =+ object [+ "arguments" .= args,+ "return" .= returnType ]++instance ToJSON API where+ toJSON (API uri types methods) =+ object ["uri" .= uri,+ "types" .= types,+ "methods" .= methods]++testAPI :: API+testAPI = API {+ apiUri = "http://home.iportnov.ru/test.api"+ , apiTypes = M.fromList [("User",TUser (M.fromList [("fullName",TText),("login",TText)]))]+ , apiMethods = M.fromList [("sayHello", Method {methodArgs = [THaskell "User"],+ methodReturnType = TText})]+ }++-- | Read API definition from file. Returned expression is of type API.+readAPI :: FilePath -> TH.ExpQ+readAPI path = do+ x <- TH.runIO $ (decodeFile path :: IO (Maybe API))+ case x of+ Nothing -> fail $ "Cannot read API from " ++ path+ Just api -> lift api+
− Network/YAML/Balancer.hs
@@ -1,19 +0,0 @@--module Network.YAML.Balancer where--import System.Random-import qualified Data.ByteString.Char8 as BS--import Network.YAML.Types---- | Select random 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'- n = length lst''- k <- randomRIO (0, n-1)- return $ lst'' !! k-
− Network/YAML/Base.hs
@@ -1,78 +0,0 @@-{-# 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)--import Network.YAML.Types--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 = toYaml x- in encode c--unserialize :: IsYamlObject a => BS.ByteString -> Maybe a-unserialize x =- let d :: Maybe YamlObject- d = decode x- in fromYaml `fmap` d-
Network/YAML/Caller.hs view
@@ -1,117 +1,35 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Network.YAML.Caller- (callDynamic,- callF,- callP- )- where+module Network.YAML.Caller where -import qualified Data.Map as M-import Data.Object.Yaml-import qualified Data.ByteString.Char8 as BS-import Network-import System.IO import Control.Monad-import Control.Concurrent--import Network.YAML.Types-import Network.YAML.Base (serialize, unserialize)-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---- | 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--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 (toYaml 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 ()--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 (toYaml 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- -> BS.ByteString -- ^ Name of method- -> a -- ^ Argument for method- -> IO b-callDynamic getServer service name args = do- srv <- getServer service- call srv name args+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS+import Data.Yaml+import qualified Network.Wreq as W+import Control.Lens+import Network.HTTP.Types --- | 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+-- | This class will be extended in future.+class Connection c where+ connectUri :: c -> String --- | 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+-- | Call remote method+call :: (ToJSON args, Connection srv, FromJSON result)+ => srv -- ^ Server connection; in simplest case - URL of service+ -> T.Text -- ^ Method name+ -> args -- ^ Method arguments+ -> IO result+call server method args = do+ let json = toJSON args+ putStrLn $ "Sending request: " ++ show json+ rs <- W.post (connectUri server ++ "/" ++ T.unpack method) json+ let body = rs ^. W.responseBody+ case decode (BL.toStrict body) of+ Nothing -> fail $ "Cannot decode response: " ++ show body+ Just result -> return result +instance Connection String where+ connectUri url = url+
− Network/YAML/Derive.hs
@@ -1,126 +0,0 @@-{-# 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.Types-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) = [| toYaml $(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 = [| fromYaml $ getItem (BS.pack c) k $(varE obj) |]- getName (n,x) = (n, getNameBase x)- --deriveToYamlObject :: Name -> Q [Dec]-deriveToYamlObject t = do- -- Get list of constructors for type t- TyConI (DataD _ _ _ constructors _) <- reify t- convbody <- mapM consClause constructors- return [FunD 'toYaml convbody]--deriveFromYamlObject :: Name -> Q [Dec]-deriveFromYamlObject t = do- TyConI (DataD _ _ _ constructors _) <- reify t- body <- mapM fromClause constructors- return [FunD 'fromYaml body]---- | Derive `instance IsYamlObject t where ...'-deriveIsYamlObject :: Name -> Q [Dec]-deriveIsYamlObject t = do- [i1] <- deriveToYamlObject t- [i2] <- deriveFromYamlObject t- let res = InstanceD [] (ConT ''IsYamlObject `AppT` ConT t) [i1, i2]- return [res]--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
@@ -1,31 +0,0 @@--module Network.YAML.Dispatcher where--import qualified Data.Map as M-import Data.Object.Yaml-import qualified Data.ByteString.Char8 as BS--import Network.YAML.Types-import Network.YAML.Instances-import Network.YAML.Server---- | 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 = fromYaml 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)---- | Similar, but use persistent server.-persistentDispatcher :: Int -> Rules -> IO ()-persistentDispatcher port rules = persistentServer port (dispatch rules)
− Network/YAML/Instances.hs
@@ -1,143 +0,0 @@-{-# 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.Types-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) => 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) => IsYamlObject (a,b) where- toYaml (x,y) = Sequence [toYaml x, toYaml 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 c) => IsYamlObject (a,b,c) where- toYaml (x,y,z) = Sequence [toYaml x, toYaml y, toYaml 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--_right :: BS.ByteString-_right = "Right"--_left :: BS.ByteString-_left = "Left"--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- toYaml = id- fromYaml = id--instance IsYamlObject Double where- fromYaml x = fromMaybe def $ getScalar x- toYaml x = Scalar $ toYamlScalar x--instance IsYamlObject Int where- 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"- toYamlScalar False = stringScalar "False"-- fromYamlScalar x = - case fromYamlScalar x :: String of- "True" -> True- _ -> False--instance Default Bool where- def = False--instance IsYamlObject Bool where- toYaml x = Scalar $ toYamlScalar x- fromYaml x = fromMaybe def $ getScalar x--instance IsYamlObject BS.ByteString where- fromYaml x = fromMaybe def $ getScalar x- toYaml x = Scalar $ toYamlScalar x--instance IsYamlObject String where- fromYaml x = fromMaybe def $ getScalar x- toYaml x = Scalar $ toYamlScalar x--mkCall :: BS.ByteString -> YamlObject -> YamlObject-mkCall name args = toYaml $ Call name args--stringScalar :: String -> YamlScalar-stringScalar = toYamlScalar--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 = fromYaml obj- y <- fn x- return $ toYaml y-
− Network/YAML/Server.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--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.Types-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- 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.--- This server closes connection after each query.--- So, each call is processed in another thread.-server ::- Int -- ^ Port number- -> 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)---- | 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 - -> Worker- -> 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/TH/Client.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards #-}++module Network.YAML.TH.Client (generateAPI, useAPI) where++import Control.Monad+import qualified Data.Map as M+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lift+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as B+import qualified Data.Vector as V+import Data.Yaml++import qualified Network.YAML.API as API+import Network.YAML.Caller++-- | Generate data types and wrapper methods declarations from API description, read from file+useAPI :: FilePath -> Q [Dec]+useAPI path = do+ x <- runIO $ decodeFileEither path+ case x of+ Left err -> fail $ "Cannot parse API description file " ++ path ++ ": " ++ show err+ Right api -> generateAPI api++-- | Generate data types and wrapper methods declarations from API description+generateAPI :: API.API -> Q [Dec]+generateAPI (API.API _ types methods) = do+ ts <- mapM generateType $ M.assocs types+ ms <- mapM generateMethod $ M.assocs methods+ return $ concat ts ++ concat ms++generateType :: (T.Text, API.Type) -> Q [Dec]+generateType (text, API.TUser fields) = do+ let name = mkName $ T.unpack text+ fields' <- mapM convertField $ M.assocs fields+ let constructor = RecC name fields'+ return [ DataD [] name [] [constructor] [] ]+generateType (_,_) = return []++convertField :: (T.Text, API.Type) -> Q VarStrictType+convertField (text, t) = do+ t' <- convertType t+ return (mkName $ T.unpack text, NotStrict, t')++convertType :: API.Type -> Q Type+convertType API.TVoid = return $ TupleT 0+convertType API.TString = return $ ConT $ mkName "String"+convertType API.TText = return $ ConT $ mkName "Text"+convertType API.TInteger = return $ ConT $ mkName "Integer"+convertType API.TDouble = return $ ConT $ mkName "Double"+convertType (API.THaskell name) = return $ ConT $ mkName (T.unpack name)+convertType (API.TList t) = AppT ListT `fmap` convertType t+convertType (API.TUser _) = fail $ "User-defined types cannot be nested"++methodType :: API.Method -> Q Type+methodType (API.Method methodArgs methodRet) = go (methodArgs ++ [methodRet])+ where+ go [r] = do+ r' <- convertType r+ return $ AppT (ConT $ mkName "IO") r'+ go (t: ts) = do+ result <- go ts+ t' <- convertType t+ return $ AppT (AppT ArrowT t') result++generateMethod :: (T.Text, API.Method) -> Q [Dec]+generateMethod (text, method) = do+ srv <- newName "srv"+ argNames <- forM (zip [0..] $ API.methodArgs method) $ \(i, _) ->+ newName $ "arg" ++ show i+ let argNamesT = map (T.pack . nameBase) argNames+ let argPatterns = map varP argNames+ args <- forM argNames $ \name -> [| toJSON $(varE name) |]+ let c = clause (varP srv: argPatterns) (normalB [| call $(varE srv) $(lift text) $(return $ ListE args) |]) []+ cName = mkName $ T.unpack text+ mt <- methodType method+ sequence [+ sigD cName [t| (Connection c) => c -> $(return mt) |],+ funD cName [c] ]++
+ Network/YAML/TH/Dispatcher.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards, FlexibleInstances #-}++module Network.YAML.TH.Dispatcher+ (ValueFn, ToValueFn (..), Dispatcher, generateDispatcher+ ) where++import Control.Monad+import Data.Aeson hiding (json)+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H+import Language.Haskell.TH+import Language.Haskell.TH.Lift++import Network.YAML.API++type ValueFn = Value -> IO Value++-- | Dispatcher function gets method name and returns corresponding function, or Nothing if there is no such method.+type Dispatcher = T.Text -> Maybe ValueFn++-- | Only functions of this class can be exposed+class ToValueFn m where+ toValueFn :: m -> ValueFn++instance (ToJSON y) => ToValueFn (IO y) where+ toValueFn fn = \rq -> do+ case rq of+ Array v -> case V.toList v of+ [] -> do+ y <- fn+ return $ toJSON y+ _ -> fail $ "Invalid number of arguments"+ _ -> fail $ "Invalid request format: " ++ show rq++instance (FromJSON x, ToValueFn f) => ToValueFn (x -> f) where+ toValueFn fn = \rq -> do+ case rq of+ Array v -> case V.toList v of+ (arg:_) ->+ case fromJSON arg of+ Error str -> fail $ "Request parsing error: " ++ str+ Success x -> do+ toValueFn (fn x) $ Array $ V.tail v+ _ -> fail $ "Invalid number of arguments"+ _ -> fail $ "Invalid request format: " ++ show rq++-- | Generate dispatcher function. This will generate function called @dispatcher@.+generateDispatcher :: API -> Q [Dec]+generateDispatcher (API _ _ methods) = do+ method <- newName "method"+ let c = clause [varP method] (normalB $ go method $ M.assocs methods) []+ cName <- newName "dispatcher"+ sequence [+ sigD cName [t| Dispatcher |],+ funD cName [c] ]+ where+ go _ [] = [| Nothing |]+ go method ((methodName, m): ms) = do+ let nameStr = T.unpack methodName+ let name = mkName nameStr + let other = go method ms+ argNames <- forM (zip [0..] $ methodArgs m) $ \(i, _) ->+ newName $ "arg" ++ show i+ [| if $(varE method) == $(return $ LitE $ StringL nameStr)+ then Just $ toValueFn $(varE name)+ else $(other) |]+
+ Network/YAML/TH/Server.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards #-}++module Network.YAML.TH.Server (makeAPI, writeAPI) where++import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Map as M+import Language.Haskell.TH+import Language.Haskell.TH.Lift+import qualified Data.Text as T+import qualified Data.ByteString as B+import Data.Yaml++import qualified Network.YAML.API as API++method :: Name -> ExpQ+method name = lift =<< method' name++method' :: Name -> Q API.Method+method' name = do+ var <- reify name+ case var of+ VarI _ funType _ _ -> go funType+ _ -> fail $ "Name is not of variable: " ++ show name+ where+ go (AppT (ConT _) r) = do+ resType <- convertType' r+ return $ API.Method [] resType+ go (AppT (AppT ArrowT a) b) = do+ arg <- convertType' a+ API.Method args res <- go b+ return $ API.Method (arg : args) res+ go t = fail $ "Unsupported function type: " ++ show t++stringLit :: String -> ExpQ+stringLit str = return $ LitE $ StringL str++convertType :: Type -> ExpQ+convertType (TupleT 0) = [| API.TVoid |]+convertType (ConT name)+ | "String" <- nameBase name = [| API.TString |]+ | "Text" <- nameBase name = [| API.TText |]+ | "Integer" <- nameBase name = [| API.TInteger |]+ | "Double" <- nameBase name = [| API.TDouble |]+ | otherwise = [| API.THaskell $ T.pack $ $(stringLit $ nameBase name) |]+convertType (AppT ListT t) = [| API.TList $(convertType t) |]+convertType t = fail $ "Unsupported type: " ++ show t++convertType' :: Type -> Q API.Type+convertType' (TupleT 0) = return $ API.TVoid+convertType' (ConT name)+ | "String" <- nameBase name = return $ API.TString+ | "Text" <- nameBase name = return $ API.TText+ | "Integer" <- nameBase name = return $ API.TInteger+ | "Double" <- nameBase name = return $ API.TDouble+ | otherwise = return $ API.THaskell (T.pack $ nameBase name)+convertType' (AppT ListT t) = API.TList `fmap` convertType' t+convertType' t = fail $ "Unsupported type: " ++ show t++testHello :: String -> IO String+testHello name = return $ "Hello, " ++ name ++ "!"++generateMethod :: Name -> Q [Dec]+generateMethod name = do+ let cName = mkName $ nameBase name+ let c = clause [] (normalB $ method name) []+ sequence [+ sigD cName [t| API.Method |],+ funD cName [c] ]++convertFields :: Con -> Q (M.Map T.Text API.Type)+convertFields (RecC name fs) = do+ let names = [T.pack (nameBase name) | (name, _, _) <- fs]+ types = [t | (_, _, t) <- fs]+ types' <- forM types $ \t -> convertType' t+ return $ M.fromList $ zip names types'++generateType :: Name -> ExpQ+generateType name = lift =<< generateType' name ++generateType' :: Name -> Q API.Type+generateType' name = do+ TyConI (DataD _ _ _ [constructor] _) <- reify name+ fields <- convertFields constructor+ return $ API.TUser fields++-- | Generate API description. Returned expression is of API type.+makeAPI :: T.Text -- ^ Service identification URI+ -> [Name] -- ^ List of exposed data type names+ -> [Name] -- ^ List of exposed method names+ -> ExpQ+makeAPI uri typeNames methodNames = do+ types <- mapM generateType typeNames+ tlist <- forM (zip typeNames types) $ \(n,t) -> [| ( $(stringLit $ nameBase n), $(return t) ) |]+ typesMap <- [| M.fromList $(return $ ListE tlist) |]+ methods <- mapM method methodNames+ mlist <- forM (zip methodNames methods) $ \(n,m) -> [| ( $(stringLit $ nameBase n), $(return m) ) |]+ methodsMap <- [| M.fromList $(return $ ListE mlist) |]+ [| API.API {+ API.apiUri = $(lift uri),+ API.apiTypes = $(return typesMap),+ API.apiMethods = $(return methodsMap)+ } |]++-- | Write API description to file.+writeAPI :: FilePath -- ^ File to write to+ -> T.Text -- ^ Service identification URI+ -> [Name] -- ^ List of exposed data type names+ -> [Name] -- ^ List of exposed method names+ -> Q [Dec]+writeAPI path uri typeNames methodNames = do+ types <- mapM generateType' typeNames+ let typesMap = M.fromList [(T.pack $ nameBase n, t) | (n, t) <- zip typeNames types]+ methods <- mapM method' methodNames+ let methodsMap = M.fromList [(T.pack $ nameBase n, m) | (n, m) <- zip methodNames methods]+ let api = API.API {+ API.apiUri = uri,+ API.apiTypes = typesMap,+ API.apiMethods = methodsMap }+ runIO $ B.writeFile path $ encode api+ return []+
− Network/YAML/WrapMethods.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Network.YAML.WrapMethods- (remote, remote', declareRules, declareRulesWithArg)- 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.Types-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| (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) |]---- | 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]]---- | 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
@@ -1,72 +0,0 @@-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.--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.--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.
+ README.md view
@@ -0,0 +1,59 @@+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 -> b -> ... -> IO c. Arguments must be of class ToJSON (defined in aeson package);+result must be of class FromJSON (defined in aeson package too). One can of+cause use GHC Generics mechanism to derive needed instances. yaml-rpc package+provides a (TemplateHaskell) function Network.YAML.TH.Server.makeAPI to+generate API description for server. Such API can be automatically written+to file in simple YAML format by using function Network.YAML.TH.Server.writeAPI.+It is possible to write different servers, which will use generated API+description and provide HTTP REST YAML services with that API. Currently there+is only one implementation using scotty package; it is provided by+yaml-rpc-scotty package. Please see yaml-rpc-scotty/Test/{Server.hs,+TestAPIImpl.hs} files for example usage.++RPC client calls that functions via HTTP REST YAML interface. So, it can be+used either from Haskell or from any other environment. For example, though+HTTP REST YAML is nearly a superset of HTTP REST JSON, it can be easily used+from JavaScript with JQuery or another framework.+For Haskell, yaml-rpc package provides a function Network.YAML.Caller.call to+call any method via HTTP REST YAML interface. Moreover, a (TemplateHaskell)+function Network.YAML.TH.Client.useAPI function will read API description from+file (in YAML format) and generate wrapper methods for calling respective+remote methods. Please see Test/Client.hs for example usage.++Currently, only one-connection-per-call mode is supported by Caller module.+There are plans to implement persistent connection support.++API description files can contain not only methods description, but also data+types description. Types description can be also automagically generated from+usual Haskell definitions and written to API description file. Then, when+reading that API description file, usual Haskell data type definitions are+generated.++Please see test.api file for example of API description format.++On the server side, usual workflow is as following:+* Write some number of API data types and functions to be exposed. +* Call makeAPI function to generate API description.+* Call writeAPI function to write API description to file.+* Call generateDispatcher function on generated API to generate function+ dispatch :: Text -> Maybe (Value -> IO Value). This function will be used by+ any server implementation.+* Launch any server implementation and provide it by dispatch function.++On the client side, usual workflow is as following:+* Receive API description file from service provider.+* Call useAPI function on that file; it will generate data types definitions+ and wrapper functions to call all methods declared in file.+* Call generated wrappers.++Depends: ghc >= 7.6, yaml, template-haskell, th-lift, wreq, lens, scotty.+
− Test.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}--- | Test server-module Main where--import Data.Object.Yaml-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 [persistentDispatcher 5000 dispatchingRules,- persistentDispatcher 5001 dispatchingRules,- persistentDispatcher 5002 dispatchingRules]- return ()
+ Test/Client.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings, DeriveGeneric, StandaloneDeriving #-}++module Test.Client where++import GHC.Generics+import Data.Maybe+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text (Text)+import Data.Aeson++import Network.YAML++import qualified Test.TestAPI as Test++$(useAPI "test.api")++deriving instance Generic User+deriving instance Show User+instance FromJSON User+instance ToJSON User++deriving instance Generic Something+instance FromJSON Something+instance ToJSON Something++main :: IO ()+main = do+ let url = "http://localhost:3000" :: String+ result <- testSmth url "zzzz" (Something {smthText = "ivan", smthList = ["Ivan", "Ivanov"]})+ print result+
+ Test/TestAPI.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}++module Test.TestAPI where++import Data.Maybe+import qualified Data.Map as M+import qualified Data.Text as T++import Network.YAML.API+import qualified Network.YAML.TH.Server as S++data User = User {userLogin :: T.Text, userFullName :: T.Text}++testApi :: API+testApi = $(readAPI "test.api")+
− TestCall.hs
@@ -1,60 +0,0 @@-{-# 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 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 :: (Connection c) => c -> String -> IO [String]---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- [host] <- getArgs- test <- getService host "test"-- (conn :: PersistentConnection) <- newConnection test--- (conn :: HostAndPort) <- newConnection test-- -- call remote functions- replicateM 100 $ do- r <- double conn p- print r---- 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
@@ -1,22 +1,19 @@ 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.3.1+Version: 1.0 -- A short (one-line) description of the package.-Synopsis: Simple library for network (TCP/IP) YAML RPC+Synopsis: Simple library for network (HTTP REST-like) 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.+ over HTTP protocol, using YAML as data serialization format. -- URL for the project homepage or repository.-Homepage: http://iportnov.ru/en/projects/yaml-rpc-0/+Homepage: http://redmine.iportnov.ru/projects/yaml-rpc -- The license under which the package is released.-License: LGPL-3+License: BSD3 -- The file containing the license text. License-file: LICENSE@@ -37,29 +34,48 @@ -- Extra files to be distributed with the package, such as examples or -- a README.-Extra-source-files: README Test.hs TestCall.hs+Extra-source-files: README.md -- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.6+Cabal-version: >= 1.8 Library -- Modules exported by the library.- Exposed-modules: Network.YAML.Derive,- Network.YAML.Server,+ Exposed-modules: Network.YAML.API Network.YAML.Caller,- Network.YAML.Dispatcher,- Network.YAML.Instances,- Network.YAML.Base,- Network.YAML.WrapMethods,- Network.YAML.Balancer,+ Network.YAML.TH.Server,+ Network.YAML.TH.Client,+ Network.YAML.TH.Dispatcher, 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, - containers, random+ Build-depends: base >= 3 && <= 5,+ transformers >= 0.3.0.0,+ aeson >= 0.7.0.3,+ yaml,+ containers,+ vector >= 0.10.11.0,+ unordered-containers >= 0.2.4.0,+ text >= 1.1.1.3,+ bytestring >= 0.10.0.2,+ template-haskell,+ th-lift,+ wreq,+ http-types >= 0.8.5,+ http-client >= 0.3.3.1,+ lens >= 4.2 + -- Modules not exported by this package.+ Other-modules: Test.Client,+ Test.TestAPI+ + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: + Source-repository head type: git- location: git://iportnov.ru/yaml-rpc.git+ location: git@github.com:portnov/yaml-rpc.git+++