diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,165 +1,30 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc.
- 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.
diff --git a/Network/YAML.hs b/Network/YAML.hs
--- a/Network/YAML.hs
+++ b/Network/YAML.hs
@@ -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
diff --git a/Network/YAML/API.hs b/Network/YAML/API.hs
new file mode 100644
--- /dev/null
+++ b/Network/YAML/API.hs
@@ -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
+
diff --git a/Network/YAML/Balancer.hs b/Network/YAML/Balancer.hs
deleted file mode 100644
--- a/Network/YAML/Balancer.hs
+++ /dev/null
@@ -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
-
diff --git a/Network/YAML/Base.hs b/Network/YAML/Base.hs
deleted file mode 100644
--- a/Network/YAML/Base.hs
+++ /dev/null
@@ -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
-
diff --git a/Network/YAML/Caller.hs b/Network/YAML/Caller.hs
--- a/Network/YAML/Caller.hs
+++ b/Network/YAML/Caller.hs
@@ -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
+
diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs
deleted file mode 100644
--- a/Network/YAML/Derive.hs
+++ /dev/null
@@ -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)
-
diff --git a/Network/YAML/Dispatcher.hs b/Network/YAML/Dispatcher.hs
deleted file mode 100644
--- a/Network/YAML/Dispatcher.hs
+++ /dev/null
@@ -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)
diff --git a/Network/YAML/Instances.hs b/Network/YAML/Instances.hs
deleted file mode 100644
--- a/Network/YAML/Instances.hs
+++ /dev/null
@@ -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
-
diff --git a/Network/YAML/Server.hs b/Network/YAML/Server.hs
deleted file mode 100644
--- a/Network/YAML/Server.hs
+++ /dev/null
@@ -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
-
diff --git a/Network/YAML/TH/Client.hs b/Network/YAML/TH/Client.hs
new file mode 100644
--- /dev/null
+++ b/Network/YAML/TH/Client.hs
@@ -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] ]
+
+
diff --git a/Network/YAML/TH/Dispatcher.hs b/Network/YAML/TH/Dispatcher.hs
new file mode 100644
--- /dev/null
+++ b/Network/YAML/TH/Dispatcher.hs
@@ -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) |]
+
diff --git a/Network/YAML/TH/Server.hs b/Network/YAML/TH/Server.hs
new file mode 100644
--- /dev/null
+++ b/Network/YAML/TH/Server.hs
@@ -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 []
+
diff --git a/Network/YAML/WrapMethods.hs b/Network/YAML/WrapMethods.hs
deleted file mode 100644
--- a/Network/YAML/WrapMethods.hs
+++ /dev/null
@@ -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]]
diff --git a/README b/README
deleted file mode 100644
--- a/README
+++ /dev/null
@@ -1,72 +0,0 @@
-YAML-RPC README
-===============
-Ilya V. Portnov
-
-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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,59 @@
+YAML-RPC README
+===============
+
+Ilya V. Portnov
+
+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.
+
diff --git a/Test.hs b/Test.hs
deleted file mode 100644
--- a/Test.hs
+++ /dev/null
@@ -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 ()
diff --git a/Test/Client.hs b/Test/Client.hs
new file mode 100644
--- /dev/null
+++ b/Test/Client.hs
@@ -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
+
diff --git a/Test/TestAPI.hs b/Test/TestAPI.hs
new file mode 100644
--- /dev/null
+++ b/Test/TestAPI.hs
@@ -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")
+
diff --git a/TestCall.hs b/TestCall.hs
deleted file mode 100644
--- a/TestCall.hs
+++ /dev/null
@@ -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
diff --git a/yaml-rpc.cabal b/yaml-rpc.cabal
--- a/yaml-rpc.cabal
+++ b/yaml-rpc.cabal
@@ -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
+
+
+