msgpack-rpc (empty) → 0.1

raw patch · 5 files changed

+198/−0 lines, 5 filesdep +basedep +msgpackdep +mtlsetup-changed

Dependencies added: base, msgpack, mtl, network, random

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• msgpack-rpc.cabal +30/−0
• src/Network/MessagePackRpc/Client.hs +66/−0
• src/Network/MessagePackRpc/Server.hs +70/−0

@@ -0,0 +1,30 @@+Copyright (c)2010, Hideyuki Tanaka++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Hideyuki Tanaka nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,30 @@+Name:                msgpack-rpc+Version:             0.1+Synopsis:            A MessagePack-RPC Implementation++Description:+  A MessagePack-RPC Implementation <http://msgpack.sourceforge.net/>++License:             BSD3+License-file:        LICENSE++Author:              Hideyuki Tanaka+Maintainer:          tanaka.hideyuki@gmail.com++Copyright:           Copyright (c) 2010, Hideyuki Tanaka++Category:            Network++Build-type:          Simple++Cabal-version:       >=1.2++Library+  Exposed-modules:+    Network.MessagePackRpc.Server+    Network.MessagePackRpc.Client++  Hs-source-dirs:      src+  +  Build-depends:       base>=4 && <5, network, random, mtl, msgpack+  Ghc-options:	       -O2 -Wall

@@ -0,0 +1,66 @@+module Network.MessagePackRpc.Client (+  Connection,+  connect,+  +  RpcMethod,+  call,+  method,+  ) where++import Control.Monad+import Data.Functor+import Data.MessagePack+import Network+import System.IO+import System.Random++data Connection+  = Connection+    { connHandle :: Handle }++connect :: String -> Int -> IO Connection+connect addr port = withSocketsDo $ do+  h <- connectTo addr (PortNumber $ fromIntegral port)+  return $ Connection+    { connHandle = h+    }+  +class RpcType r where+  rpcc :: Connection -> String -> [Object] -> r++fromObject' :: OBJECT o => Object -> o+fromObject' o = let Right r = fromObject o in r++instance OBJECT o => RpcType (IO o) where+  rpcc c m args = fromObject' <$> rpcCall c m (reverse args)++instance (OBJECT o, RpcType r) => RpcType (o -> r) where+  rpcc c m args arg = rpcc c m (toObject arg:args)++rpcCall :: Connection -> String -> [Object] -> IO Object+rpcCall Connection{ connHandle = h } m args = do+  msgid <- (`mod`2^(32::Int)) <$> randomIO :: IO Int+  packToHandle h $ do+    put [ toObject (0 :: Int)+        , toObject msgid+        , toObject m+        , toObject args+        ]+  unpackFromHandle h $ do+    [ rtype, rmsgid, rerror, rresult ] <- get+    Right 1 <- return (fromObject rtype :: Result Int)+    Right rmsgid <- return $ fromObject rmsgid+    when (rmsgid /= msgid) $ fail $ "msgid mismatch: " ++ show msgid ++ " <-> " ++ show rmsgid+    Right () <- return $ fromObject rerror+    Right rresult <- return $ fromObject rresult+    return rresult++--++call :: RpcType a => Connection -> String -> a+call c m = rpcc c m []++method :: RpcType a => String -> Connection -> a+method c m = call m c++type RpcMethod a = Connection -> a

@@ -0,0 +1,70 @@+module Network.MessagePackRpc.Server (+  RpcMethod,+  fun,+  serve,+  ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Maybe+import Data.MessagePack+import Network+import System.IO++import Prelude hiding (catch)++type RpcMethod = [Object] -> IO Object++class RpcMethodType f where+  toRpcMethod :: f -> RpcMethod++instance OBJECT o => RpcMethodType (IO o) where+  toRpcMethod m = \[] -> toObject <$> m++instance (OBJECT o, RpcMethodType r) => RpcMethodType (o -> r) where+  toRpcMethod f = \(x:xs) -> toRpcMethod (f (fromObject' x)) xs++fromObject' :: OBJECT o => Object -> o+fromObject' o = let Right r = fromObject o in r++--++fun :: RpcMethodType f => f -> RpcMethod+fun = toRpcMethod++serve :: Int -> [(String, RpcMethod)] -> IO ()+serve port methods = withSocketsDo $ do+  sock <- listenOn (PortNumber $ fromIntegral port)+  forever $ do+    (h, host, port) <- accept sock+    forkIO $+      processRequests h `finally` hClose h+      `catch` \(SomeException e) -> print e+  +  where+    processRequests h =+      forever $ processRequest h+    +    processRequest h = do+      (msgid, method, args) <- unpackFromHandle h $ do+        [ rtype, rmsgid, rmethod, rargs ] <- get+        0      <- return (fromObject' rtype :: Int)+        msgid  <- return (fromObject' rmsgid :: Int)+        method <- return (fromObject' rmethod :: String)+        args   <- return (fromObject' rargs :: [Object])+        return (msgid, method, args)+      +      ret <- callMethod method args+      +      packToHandle h $ do+        put [ toObject (1 :: Int)+            , toObject msgid+            , toObject ()+            , ret+            ]+    +    callMethod methodName args = do+      let method = fromJust $ lookup methodName methods+      method args