diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,4 @@ +2014-07-25 Rodrigo Setti + + * Initial version. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/MessagePack.hs b/Network/MessagePack.hs new file mode 100644 --- /dev/null +++ b/Network/MessagePack.hs @@ -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) ] + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# messagepack-rpc + +[Message Pack](http://msgpack.org) RPC over TCP. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/messagepack-rpc.cabal b/messagepack-rpc.cabal new file mode 100644 --- /dev/null +++ b/messagepack-rpc.cabal @@ -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 +