messagepack-rpc (empty) → 0.1.0.0
raw patch · 6 files changed
+158/−0 lines, 6 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, containers, messagepack, network-simple, text
Files
- CHANGELOG +4/−0
- LICENSE +20/−0
- Network/MessagePack.hs +95/−0
- README.md +4/−0
- Setup.hs +2/−0
- messagepack-rpc.cabal +33/−0
+ CHANGELOG view
@@ -0,0 +1,4 @@+2014-07-25 Rodrigo Setti <rodrigosetti@gmail.com>++ * Initial version.+
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Rodrigo Setti++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Network/MessagePack.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module : Network.MessagePack+Description : Message pack RPC over TCP+Copyright : (c) 2014, Rodrigo Setti+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+module Network.MessagePack ( Method+ , runRPC ) where++import Control.Applicative+import Control.Monad+import Data.MessagePack+import Network.Simple.TCP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M+import qualified Data.Serialize as S+import qualified Data.Text as T++type MsgId = Int+type MsgType = Int++reqMessage :: MsgType+reqMessage = 0++resMessage :: MsgType+resMessage = 1++errorMsgId :: Int+errorMsgId = 0++-- | The type of a message pack RPC method. It gets an Object as a parameter, and+-- returns either an error or the result as an Object.+type Method = Object -> IO (Either String Object)++-- | Start the RPC server binding the socket using the given preferences, and+-- using the RPC methods defined in the map of method name -> Method.+runRPC :: M.Map T.Text Method -> HostPreference -> ServiceName -> IO ()+runRPC methods host service = + serve host service rpcServer+ where+ rpcServer (socket, _) =+ do bs <- LBS.fromChunks <$> fetchData+ send socket =<< LBS.toStrict <$> executeRPC methods bs+ where+ chunkSize = 1024+ fetchData = do maybeData <- recv socket chunkSize+ case maybeData of+ Nothing -> return []+ Just s -> do let len = BS.length s+ if len < chunkSize+ then return [s]+ else do rest <- fetchData+ return $ s : rest++executeRPC :: M.Map T.Text Method -> LBS.ByteString -> IO LBS.ByteString+executeRPC methods input = + case getRPCData of+ Left err -> return $ errorResponse errorMsgId err+ Right (method, msgid, params) -> do result <- method params+ return $ either (errorResponse msgid) (resultResponse msgid) result+ where+ getRPCData =+ do let m .: k = maybe (Left $ "missing key: " ++ show k) Right $ M.lookup (ObjectString k) m+ getMethod ms name = maybe (Left $ "unsupported method: " ++ show name) Right $ M.lookup name ms+ obj <- S.decodeLazy input+ case obj of+ (ObjectMap m) -> do ObjectInt type_ <- m .: "type"+ when (type_ /= reqMessage) $ Left $ "invalid RPC type: " ++ show type_++ ObjectString methodName <- m .: "method"+ method <- getMethod methods methodName++ ObjectInt msgid <- m .: "msgid"+ params <- m .: "params"+ return (method, msgid, params)+ _ -> Left "invalid msgpack RPC request"++errorResponse :: MsgId -> String -> LBS.ByteString+errorResponse msgid err = response msgid (ObjectString $ T.pack err) ObjectNil++resultResponse :: MsgId -> Object -> LBS.ByteString+resultResponse msgid = response msgid ObjectNil++response :: MsgId -> Object -> Object -> LBS.ByteString+response msgid errObj resObj =+ S.encodeLazy $ ObjectMap $ M.fromList [ (ObjectString "type" , ObjectInt resMessage)+ , (ObjectString "msgid" , ObjectInt msgid)+ , (ObjectString "error" , errObj)+ , (ObjectString "result", resObj) ]+
+ README.md view
@@ -0,0 +1,4 @@+# messagepack-rpc++[Message Pack](http://msgpack.org) RPC over TCP.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ messagepack-rpc.cabal view
@@ -0,0 +1,33 @@+name : messagepack-rpc+version : 0.1.0.0+synopsis : Message Pack RPC over TCP+description : Message Pack RPC over TCP+homepage : http://github.com/rodrigosetti/messagepack-rpc+package-url : https://github.com/rodrigosetti/messagepack-rpc/archive/master.zip+license : MIT+license-file : LICENSE+author : Rodrigo Setti+maintainer : rodrigosetti@gmail.com+copyright : (c) 2014 Rodrigo Setti+category : Network+build-type : Simple+extra-source-files : CHANGELOG+cabal-version : >=1.10+extra-source-files : CHANGELOG+ , README.md++source-repository head+ type : git+ location : git@github.com:rodrigosetti/messagepack.git++library+ exposed-modules : Network.MessagePack+ build-depends : base == 4.*+ , bytestring == 0.10.*+ , cereal == 0.4.*+ , containers == 0.5.*+ , messagepack == 0.2.*+ , network-simple == 0.4.*+ , text == 1.*+ default-language : Haskell2010+