From b2a81b581db7f328e0ec345104fb2fea1cae1296 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 11 May 2013 13:40:58 +0400 Subject: Initial commit. --- .gitignore | 2 + LICENSE | 19 ++++ Setup.hs | 2 + examples/Client.hs | 18 ++++ examples/Server.hs | 9 ++ examples/Shared.hs | 9 ++ krpc.cabal | 60 +++++++++++++ src/Remote/KRPC.hs | 132 ++++++++++++++++++++++++++++ src/Remote/KRPC/Method.hs | 76 ++++++++++++++++ src/Remote/KRPC/Protocol.hs | 207 ++++++++++++++++++++++++++++++++++++++++++++ 10 files changed, 534 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 examples/Client.hs create mode 100644 examples/Server.hs create mode 100644 examples/Shared.hs create mode 100644 krpc.cabal create mode 100644 src/Remote/KRPC.hs create mode 100644 src/Remote/KRPC/Method.hs create mode 100644 src/Remote/KRPC/Protocol.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..316009b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +cabal-dev diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..dd0c3581 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013 Sam T. + +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/Setup.hs b/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Client.hs b/examples/Client.hs new file mode 100644 index 00000000..bf486cb5 --- /dev/null +++ b/examples/Client.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import System.Environment +import Remote.KRPC +import Shared + + +addr :: RemoteAddr +addr = (0, 6000) + +main :: IO () +main = print =<< call addr echoInt . read . head =<< getArgs + +{- + forM_ [1..] $ const $ do + async addr myconcat (replicate 100 [1..10]) +-} diff --git a/examples/Server.hs b/examples/Server.hs new file mode 100644 index 00000000..027e0453 --- /dev/null +++ b/examples/Server.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Remote.KRPC +import Shared + + +main :: IO () +main = server 6000 [handler echoInt] diff --git a/examples/Shared.hs b/examples/Shared.hs new file mode 100644 index 00000000..77986125 --- /dev/null +++ b/examples/Shared.hs @@ -0,0 +1,9 @@ +module Shared (echoInt, myconcat) where + +import Remote.KRPC + +echoInt :: Method IO Int Int +echoInt = idM + +myconcat :: Method IO [[Int]] [Int] +myconcat = concatM \ No newline at end of file diff --git a/krpc.cabal b/krpc.cabal new file mode 100644 index 00000000..e62d0aa7 --- /dev/null +++ b/krpc.cabal @@ -0,0 +1,60 @@ +name: krpc +version: 0.1.0.0 +license: MIT +license-file: LICENSE +author: Sam T. +maintainer: Sam T. +copyright: (c) 2013, Sam T. +category: Network, Remote +build-type: Simple +cabal-version: >=1.8 +homepage: https://github.com/pxqr/krpc +bug-reports: https://github.com/pxqr/krpc/issues +synopsis: KRPC remote procedure call protocol implementation. +description: KRPC remote procedure call protocol implementation. + + +library + exposed-modules: Remote.KRPC + , Remote.KRPC.Protocol + , Remote.KRPC.Method + + build-depends: base == 4.* + + , lifted-base >= 0.1.1 + , transformers >= 0.2 + , monad-control >= 0.3 + + , bytestring >= 0.10 + , containers >= 0.4 + , text >= 0.11 + , bencoding >= 0.1 + + , network >= 2.3 + + + hs-source-dirs: src + extensions: PatternGuards + ghc-options: -Wall + + + +executable echo-client + main-is: Client.hs + other-modules: Shared + + build-depends: base == 4.* + , krpc + + hs-source-dirs: examples + + + +executable echo-server + main-is: Server.hs + other-modules: Shared + + build-depends: base == 4.* + , krpc + + hs-source-dirs: examples diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs new file mode 100644 index 00000000..a6318ccd --- /dev/null +++ b/src/Remote/KRPC.hs @@ -0,0 +1,132 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides remote procedure call. +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll, KindSignatures #-} +module Remote.KRPC + ( module Remote.KRPC.Method, RemoteAddr + + -- * Client + , call, async, await + + -- * Server + , handler, server + ) where + +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Control +import Control.Monad.IO.Class +import Data.BEncode +import Data.List as L +import Data.Map as M +import Data.Text as T +import Data.Typeable +import Network + +import Remote.KRPC.Protocol +import Remote.KRPC.Method + + +data RPCException = RPCException KError + deriving (Show, Eq, Typeable) + +instance Exception RPCException + + +type RemoteAddr = KRemoteAddr + + +queryCall :: BEncodable param + => KRemote -> KRemoteAddr + -> Method remote param result -> param -> IO () +queryCall sock addr m arg = sendMessage q addr sock + where + q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] + +getResult :: BEncodable result + => KRemote -> KRemoteAddr + -> Method remote param result -> IO result +getResult sock addr m = do + resp <- recvResponse addr sock + case resp of + Left e -> throw (RPCException e) + Right (KResponse dict) -> do + let valName = L.head (methodVals m) + case M.lookup valName dict of + Just val | Right res <- fromBEncode val -> return res + Nothing -> throw (RPCException (ProtocolError msg)) + where + msg = T.concat + [ "Unable to find return value: ", T.pack (show valName), "\n" + , "in response: ", T.pack (show dict) + ] + +-- TODO async call +-- | Makes remote procedure call. Throws RPCException if server +-- returns error or decode error occurred. +-- +call :: (MonadBaseControl IO host, MonadIO host) + => (BEncodable param, BEncodable result) + => RemoteAddr + -> Method remote param result + -> param + -> host result +call addr m arg = liftIO $ withRemote $ \sock -> do + queryCall sock addr m arg + getResult sock addr m + + +newtype Async result = Async { waitResult :: IO result } + +async :: MonadIO host + => (BEncodable param, BEncodable result) + => RemoteAddr + -> Method remote param result + -> param + -> host (Async result) +async addr m arg = do + liftIO $ withRemote $ \sock -> + queryCall sock addr m arg + return $ Async $ withRemote $ \sock -> + getResult sock addr m + +await :: MonadIO host => Async result -> host result +await = liftIO . waitResult + +-- TODO better name +type MHandler remote = Method remote BEncode (Result BEncode) + +handler :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncodable param, BEncodable result) + => Monad remote + => Method remote param result + -> Method remote BEncode (Result BEncode) +handler m = m { methodBody = \x -> do + case fromBEncode x of + Right a -> liftM (Right . toBEncode) (methodBody m a) + Left e -> return (Left e) + } + +-- TODO: allow forkIO +server :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber + -> [MHandler remote] + -> remote () +server servport ms = remoteServer servport $ \_ q -> do + let name = queryMethod q + let args = queryArgs q + let m = L.head ms + res <- methodBody m (snd (L.head (M.toList args))) + case res of + Left r -> return (Left (ProtocolError (T.pack r))) + Right r -> do + let retName = L.head (methodVals m) + return (Right (kresponse [(retName, r)])) diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs new file mode 100644 index 00000000..f4b0bb9a --- /dev/null +++ b/src/Remote/KRPC/Method.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module Remote.KRPC.Method + ( Method(methodName, methodParams, methodVals, methodBody) + + -- * Construction + , method + + -- * Predefined methods + , idM, composeM, concatM + ) where + +import Prelude hiding ((.), id) +import Control.Category +import Control.Monad + +import Remote.KRPC.Protocol + +-- | The +-- +-- * argument: type of method parameter +-- +-- * remote: A monad used by server-side. +-- +-- * result: type of return value of the method. +-- +data Method remote param result = Method { + -- | Name used in query and + methodName :: [MethodName] + + -- | Description of each method parameter in right to left order. + , methodParams :: [ParamName] + + -- | Description of each method return value in right to left order. + , methodVals :: [ValName] + + -- | Description of method body. + , methodBody :: param -> remote result + } + +instance Monad remote => Category (Method remote) where + id = idM + (.) = composeM + +-- | Remote identity function. Could be used for echo servers for example. +-- +-- idM = method "id" ["x"] ["y"] return +-- +idM :: Monad m => Method m a a +idM = method "id" ["x"] ["y"] return + +-- | Pipelining of two or more methods. +-- +-- NOTE: composed methods will work only with this implementation of +-- KRPC, so both server and client should use this implementation, +-- otherwise you more likely get the 'ProtocolError'. +-- +composeM :: Monad m => Method m b c -> Method m a b -> Method m a c +composeM g h = Method (methodName g ++ methodName h) + (methodParams h) + (methodVals g) + (methodBody h >=> methodBody g) + +-- | Concat list of list. Could be used for performance tests. +-- +-- concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat +-- +concatM :: Monad m => Method m [[a]] [a] +concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat + + +method :: MethodName + -> [ParamName] + -> [ValName] + -> (param -> remote result) + -> Method remote param result +method name = Method [name] diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs new file mode 100644 index 00000000..0aa7e100 --- /dev/null +++ b/src/Remote/KRPC/Protocol.hs @@ -0,0 +1,207 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides straightforward implementation of KRPC +-- protocol. In many situations Network.KRPC should be prefered +-- since it gives more safe, convenient and high level api. +-- +-- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol +-- +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Remote.KRPC.Protocol + ( + -- * Error + KError(..), errorCode, mkKError + + -- * Query + , KQuery(..), MethodName, ParamName, kquery + + -- * Response + , KResponse(..), ValName, kresponse + , sendMessage, recvResponse + + -- * Remote + , KRemote, KRemoteAddr, withRemote, remoteServer + + -- * Re-exports + , encode, encoded, decode, decoded, toBEncode, fromBEncode + ) where + +import Control.Applicative +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Control +import Data.BEncode +import Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import Data.Map as M +import Data.Text as T +import Network.Socket hiding (recvFrom) +import Network.Socket.ByteString + + +data KError + = GenericError { errorMessage :: Text } + | ServerError { errorMessage :: Text } + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError { errorMessage :: Text } + | MethodUnknown { errorMessage :: Text } + deriving (Show, Read, Eq, Ord) + +instance BEncodable KError where + toBEncode e = fromAssocs + [ "y" --> ("e" :: ByteString) + , "e" --> (errorCode e, errorMessage e) + ] + + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "e") = + uncurry mkKError <$> d >-- "e" + + fromBEncode _ = decodingError "KError" + +type ErrorCode = Int + +errorCode :: KError -> ErrorCode +errorCode (GenericError _) = 201 +errorCode (ServerError _) = 202 +errorCode (ProtocolError _) = 203 +errorCode (MethodUnknown _) = 204 + +mkKError :: ErrorCode -> Text -> KError +mkKError 201 = GenericError +mkKError 202 = ServerError +mkKError 203 = ProtocolError +mkKError 204 = MethodUnknown +mkKError _ = GenericError + + + +type MethodName = ByteString +type ParamName = ByteString + +data KQuery = KQuery { + queryMethod :: MethodName + , queryArgs :: Map ParamName BEncode + } deriving (Show, Read, Eq, Ord) + +instance BEncodable KQuery where + toBEncode (KQuery m args) = fromAssocs + [ "y" --> ("q" :: ByteString) + , "q" --> m + , "a" --> BDict args + ] + + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "q") = + KQuery <$> d >-- "q" + <*> d >-- "a" + + fromBEncode _ = decodingError "KQuery" + +kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery +kquery name args = KQuery name (M.fromList args) + + + + +type ValName = ByteString + +newtype KResponse = KResponse (Map ValName BEncode) + deriving (Show, Read, Eq, Ord) + +instance BEncodable KResponse where + toBEncode (KResponse vals) = fromAssocs + [ "y" --> ("r" :: ByteString) + , "r" --> vals + ] + + + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "r") = + KResponse <$> d >-- "r" + + fromBEncode _ = decodingError "KDict" + +kresponse :: [(ValName, BEncode)] -> KResponse +kresponse = KResponse . M.fromList + + +type KRemoteAddr = (HostAddress, PortNumber) + +remoteAddr :: KRemoteAddr -> SockAddr +remoteAddr = SockAddrInet <$> snd <*> fst + +type KRemote = Socket + +withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a +withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) + (liftIO . sClose) + +maxMsgSize :: Int +maxMsgSize = 16 * 1024 + +-- TODO eliminate toStrict +sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage msg (host, port) sock = + sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) + +recvResponse :: KRemoteAddr -> KRemote -> IO (Either KError KResponse) +recvResponse addr sock = do + connect sock (remoteAddr addr) + (raw, _) <- recvFrom sock maxMsgSize + return $ case decoded raw of + Right resp -> Right resp + Left decE -> Left $ case decoded raw of + Right kerror -> kerror + _ -> ProtocolError (T.pack decE) + +remoteServer :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber + -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) + -> remote () +remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop + where + bind = do + sock <- socket AF_INET Datagram defaultProtocol + bindSocket sock (SockAddrInet servport iNADDR_ANY) + return sock + + loop sock = forever $ do + (bs, addr) <- liftIO $ recvFrom sock maxMsgSize + + case addr of + SockAddrInet port host -> + case decoded bs of + Right query -> do + res <- action (host, port) query + case res of + Right resp -> liftIO $ sendMessage resp (host, port) sock + Left err -> liftIO $ sendMessage err (host, port) sock + + Left decodeE -> liftIO $ sendMessage rpcE (host, port) sock + where + rpcE = ProtocolError $ T.concat + ["Unable to decode query: ", T.pack (show bs), "\n" + ,"Specifically: ", T.pack decodeE + ] + _ -> return () + + + +-- TODO to bencodable +instance (BEncodable a, BEncodable b) => BEncodable (a, b) where + {-# SPECIALIZE instance (BEncodable a, BEncodable b) => BEncodable (a, b) #-} + toBEncode (a, b) = BList [toBEncode a, toBEncode b] + {-# INLINE toBEncode #-} + + fromBEncode be = case fromBEncode be of + Right [a, b] -> (,) <$> fromBEncode a <*> fromBEncode b + Right _ -> decodingError "Unable to decode a pair." + Left e -> Left e + {-# INLINE fromBEncode #-} \ No newline at end of file -- cgit v1.2.3 From 96c554f6ab63e6e207d0c7e65d3ef1cdef7baa9c Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 11 May 2013 21:26:54 +0400 Subject: + Add scheme for error, query and resp. --- src/Remote/KRPC/Protocol.hs | 75 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 68 insertions(+), 7 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 0aa7e100..8f6cc442 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -11,14 +11,20 @@ -- -- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol -- -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} module Remote.KRPC.Protocol ( + -- * Message + KMessage(..) + -- * Error - KError(..), errorCode, mkKError + , KError(..), errorCode, mkKError -- * Query - , KQuery(..), MethodName, ParamName, kquery + , KQuery(queryMethod, queryParams), MethodName, ParamName, kquery -- * Response , KResponse(..), ValName, kresponse @@ -40,11 +46,30 @@ import Data.BEncode import Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Map as M +import Data.Set as S import Data.Text as T import Network.Socket hiding (recvFrom) import Network.Socket.ByteString + +-- | Used to validate message by its scheme +-- +-- forall m. m `validate` scheme m +-- +class KMessage message scheme | message -> scheme where + -- | Get a message scheme. + scheme :: message -> scheme + + -- | Check a message with a scheme. + validate :: message -> scheme -> Bool + + default validate :: Eq scheme => message -> scheme -> Bool + validate = (==) . scheme + {-# INLINE validate #-} + + +-- TODO document that it is and how transferred data KError = GenericError { errorMessage :: Text } | ServerError { errorMessage :: Text } @@ -65,6 +90,11 @@ instance BEncodable KError where fromBEncode _ = decodingError "KError" +instance KMessage KError ErrorCode where + {-# SPECIALIZE instance KMessage KError ErrorCode #-} + scheme = errorCode + {-# INLINE scheme #-} + type ErrorCode = Int errorCode :: KError -> ErrorCode @@ -72,6 +102,7 @@ errorCode (GenericError _) = 201 errorCode (ServerError _) = 202 errorCode (ProtocolError _) = 203 errorCode (MethodUnknown _) = 204 +{-# INLINE errorCode #-} mkKError :: ErrorCode -> Text -> KError mkKError 201 = GenericError @@ -79,15 +110,20 @@ mkKError 202 = ServerError mkKError 203 = ProtocolError mkKError 204 = MethodUnknown mkKError _ = GenericError +{-# INLINE mkKError #-} + +-- TODO Asc everywhere + type MethodName = ByteString type ParamName = ByteString +-- TODO document that it is and how transferred data KQuery = KQuery { queryMethod :: MethodName - , queryArgs :: Map ParamName BEncode + , queryParams :: Map ParamName BEncode } deriving (Show, Read, Eq, Ord) instance BEncodable KQuery where @@ -106,14 +142,27 @@ instance BEncodable KQuery where kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery kquery name args = KQuery name (M.fromList args) +{-# INLINE kquery #-} +data KQueryScheme = KQueryScheme { + qscMethod :: MethodName + , qscParams :: Set ParamName + } deriving (Show, Read, Eq, Ord) +domen :: Map a b -> Set a +domen = error "scheme.domen" +instance KMessage KQuery KQueryScheme where + {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} + scheme q = KQueryScheme (queryMethod q) (domen (queryParams q)) + {-# INLINE scheme #-} type ValName = ByteString -newtype KResponse = KResponse (Map ValName BEncode) - deriving (Show, Read, Eq, Ord) +-- TODO document that it is and how transferred +newtype KResponse = KResponse { + respVals :: Map ValName BEncode + } deriving (Show, Read, Eq, Ord) instance BEncodable KResponse where toBEncode (KResponse vals) = fromAssocs @@ -121,21 +170,33 @@ instance BEncodable KResponse where , "r" --> vals ] - fromBEncode (BDict d) | M.lookup "y" d == Just (BString "r") = KResponse <$> d >-- "r" fromBEncode _ = decodingError "KDict" + kresponse :: [(ValName, BEncode)] -> KResponse kresponse = KResponse . M.fromList +{-# INLINE kresponse #-} + +newtype KResponseScheme = KResponseScheme { + rscVals :: Set ValName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KResponse KResponseScheme where + {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} + scheme = KResponseScheme . domen . respVals + {-# INLINE scheme #-} type KRemoteAddr = (HostAddress, PortNumber) remoteAddr :: KRemoteAddr -> SockAddr remoteAddr = SockAddrInet <$> snd <*> fst +{-# INLINE remoteAddr #-} + type KRemote = Socket -- cgit v1.2.3 From 3806b3513f04dd360badf438fa103334dd32933c Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 11 May 2013 21:31:05 +0400 Subject: ~ Separate method implementation. This will break everything for now. --- examples/Server.hs | 2 +- examples/Shared.hs | 7 ++----- src/Remote/KRPC.hs | 39 +++++++++++++++++++++++---------------- src/Remote/KRPC/Method.hs | 47 ++++++++++++++++++++++------------------------- 4 files changed, 48 insertions(+), 47 deletions(-) diff --git a/examples/Server.hs b/examples/Server.hs index 027e0453..550bc344 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -6,4 +6,4 @@ import Shared main :: IO () -main = server 6000 [handler echoInt] +main = server 6000 [undefined] diff --git a/examples/Shared.hs b/examples/Shared.hs index 77986125..efe345ac 100644 --- a/examples/Shared.hs +++ b/examples/Shared.hs @@ -1,9 +1,6 @@ -module Shared (echoInt, myconcat) where +module Shared (echoInt) where import Remote.KRPC -echoInt :: Method IO Int Int +echoInt :: Method Int Int echoInt = idM - -myconcat :: Method IO [[Int]] [Int] -myconcat = concatM \ No newline at end of file diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index a6318ccd..8f2027f2 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -17,7 +17,7 @@ module Remote.KRPC , call, async, await -- * Server - , handler, server + , server ) where import Control.Exception @@ -46,14 +46,14 @@ type RemoteAddr = KRemoteAddr queryCall :: BEncodable param => KRemote -> KRemoteAddr - -> Method remote param result -> param -> IO () + -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] getResult :: BEncodable result => KRemote -> KRemoteAddr - -> Method remote param result -> IO result + -> Method param result -> IO result getResult sock addr m = do resp <- recvResponse addr sock case resp of @@ -76,7 +76,7 @@ getResult sock addr m = do call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) => RemoteAddr - -> Method remote param result + -> Method param result -> param -> host result call addr m arg = liftIO $ withRemote $ \sock -> do @@ -86,10 +86,11 @@ call addr m arg = liftIO $ withRemote $ \sock -> do newtype Async result = Async { waitResult :: IO result } +-- TODO document errorneous usage async :: MonadIO host => (BEncodable param, BEncodable result) => RemoteAddr - -> Method remote param result + -> Method param result -> param -> host (Async result) async addr m arg = do @@ -102,31 +103,37 @@ await :: MonadIO host => Async result -> host result await = liftIO . waitResult -- TODO better name -type MHandler remote = Method remote BEncode (Result BEncode) +type MHandler remote = ( Method BEncode (Result BEncode) + , BEncode -> remote (Result BEncode) + ) -handler :: forall (remote :: * -> *) (param :: *) (result :: *). +-- we can safely erase types in (==>) +(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). (BEncodable param, BEncodable result) => Monad remote - => Method remote param result - -> Method remote BEncode (Result BEncode) -handler m = m { methodBody = \x -> do - case fromBEncode x of - Right a -> liftM (Right . toBEncode) (methodBody m a) + => Method param result + -> (param -> remote result) + -> MHandler remote +m ==> body = undefined + where + newbody x = case fromBEncode x of + Right a -> liftM (Right . toBEncode) (body a) Left e -> return (Left e) - } + -- TODO: allow forkIO +-- TODO: allow overloading server :: (MonadBaseControl IO remote, MonadIO remote) => PortNumber -> [MHandler remote] -> remote () server servport ms = remoteServer servport $ \_ q -> do let name = queryMethod q - let args = queryArgs q + let args = undefined -- queryArgs q let m = L.head ms - res <- methodBody m (snd (L.head (M.toList args))) + res <- undefined -- methodBody m (snd (L.head (M.toList args))) case res of Left r -> return (Left (ProtocolError (T.pack r))) Right r -> do - let retName = L.head (methodVals m) + let retName = undefined -- L.head (methodVals m) return (Right (kresponse [(retName, r)])) diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index f4b0bb9a..3c757d07 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Remote.KRPC.Method - ( Method(methodName, methodParams, methodVals, methodBody) + ( Method(methodName, methodParams, methodVals) -- * Construction , method -- * Predefined methods - , idM, composeM, concatM + , idM, composeM ) where import Prelude hiding ((.), id) @@ -15,6 +15,8 @@ import Control.Monad import Remote.KRPC.Protocol + + -- | The -- -- * argument: type of method parameter @@ -23,30 +25,35 @@ import Remote.KRPC.Protocol -- -- * result: type of return value of the method. -- -data Method remote param result = Method { +data Method param result = Method { -- | Name used in query and methodName :: [MethodName] - -- | Description of each method parameter in right to left order. + -- | Description of each parameter in /right to left/ order. , methodParams :: [ParamName] - -- | Description of each method return value in right to left order. + -- | Description of each return value in /right to left/ order. , methodVals :: [ValName] - - -- | Description of method body. - , methodBody :: param -> remote result } -instance Monad remote => Category (Method remote) where +instance Category Method where + {-# SPECIALIZE instance Category Method #-} id = idM + {-# INLINE id #-} + (.) = composeM + {-# INLINE (.) #-} + + +-- TODO ppMethod -- | Remote identity function. Could be used for echo servers for example. -- -- idM = method "id" ["x"] ["y"] return -- -idM :: Monad m => Method m a a -idM = method "id" ["x"] ["y"] return +idM :: Method a a +idM = method "id" ["x"] ["y"] +{-# INLINE idM #-} -- | Pipelining of two or more methods. -- @@ -54,23 +61,13 @@ idM = method "id" ["x"] ["y"] return -- KRPC, so both server and client should use this implementation, -- otherwise you more likely get the 'ProtocolError'. -- -composeM :: Monad m => Method m b c -> Method m a b -> Method m a c +composeM :: Method b c -> Method a b -> Method a c composeM g h = Method (methodName g ++ methodName h) (methodParams h) (methodVals g) - (methodBody h >=> methodBody g) - --- | Concat list of list. Could be used for performance tests. --- --- concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat --- -concatM :: Monad m => Method m [[a]] [a] -concatM = method "concat" ["xxs"] ["xs"] $ return . Prelude.concat +{-# INLINE composeM #-} -method :: MethodName - -> [ParamName] - -> [ValName] - -> (param -> remote result) - -> Method remote param result +method :: MethodName -> [ParamName] -> [ValName] -> Method param result method name = Method [name] +{-# INLINE method #-} \ No newline at end of file -- cgit v1.2.3 From 7614ed760e137219fb4e36288abf1e78eacb2266 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 11 May 2013 23:50:08 +0400 Subject: ~ Catch server fails. --- src/Remote/KRPC/Protocol.hs | 49 +++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 8f6cc442..e7fbea11 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -25,9 +25,12 @@ module Remote.KRPC.Protocol -- * Query , KQuery(queryMethod, queryParams), MethodName, ParamName, kquery + , KQueryScheme(qscMethod, qscParams) -- * Response - , KResponse(..), ValName, kresponse + , KResponse(respVals), ValName, kresponse + , KResponseScheme(rscVals) + , sendMessage, recvResponse -- * Remote @@ -37,6 +40,7 @@ module Remote.KRPC.Protocol , encode, encoded, decode, decoded, toBEncode, fromBEncode ) where +import Prelude hiding (catch) import Control.Applicative import Control.Exception.Lifted import Control.Monad @@ -71,10 +75,16 @@ class KMessage message scheme | message -> scheme where -- TODO document that it is and how transferred data KError + -- | Some error doesn't fit in any other category. = GenericError { errorMessage :: Text } + + -- | Occur when server fail to process procedure call. | ServerError { errorMessage :: Text } + -- | Malformed packet, invalid arguments or bad token. | ProtocolError { errorMessage :: Text } + + -- | Occur when client trying to call method server don't know. | MethodUnknown { errorMessage :: Text } deriving (Show, Read, Eq, Ord) @@ -112,7 +122,8 @@ mkKError 204 = MethodUnknown mkKError _ = GenericError {-# INLINE mkKError #-} - +serverError :: SomeException -> KError +serverError = ServerError . T.pack . show -- TODO Asc everywhere @@ -211,7 +222,11 @@ maxMsgSize = 16 * 1024 sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () sendMessage msg (host, port) sock = sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) +{-# INLINE sendMessage #-} +{-# SPECIALIZE sendMessage :: BEncode -> KRemoteAddr -> KRemote -> IO () #-} + +-- TODO check scheme recvResponse :: KRemoteAddr -> KRemote -> IO (Either KError KResponse) recvResponse addr sock = do connect sock (remoteAddr addr) @@ -222,6 +237,7 @@ recvResponse addr sock = do Right kerror -> kerror _ -> ProtocolError (T.pack decE) + remoteServer :: (MonadBaseControl IO remote, MonadIO remote) => PortNumber -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) @@ -235,24 +251,23 @@ remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop loop sock = forever $ do (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - case addr of - SockAddrInet port host -> - case decoded bs of - Right query -> do - res <- action (host, port) query - case res of - Right resp -> liftIO $ sendMessage resp (host, port) sock - Left err -> liftIO $ sendMessage err (host, port) sock - - Left decodeE -> liftIO $ sendMessage rpcE (host, port) sock - where - rpcE = ProtocolError $ T.concat - ["Unable to decode query: ", T.pack (show bs), "\n" - ,"Specifically: ", T.pack decodeE - ] + SockAddrInet port host -> do + let kaddr = (host, port) + reply <- handleMsg bs kaddr + liftIO $ sendMessage reply kaddr sock _ -> return () + where + handleMsg bs addr = case decoded bs of + Right query -> (either toBEncode toBEncode <$> action addr query) + `catch` (return . toBEncode . serverError) + Left decodeE -> return $ toBEncode rpcE + where + rpcE = ProtocolError $ T.concat + ["Unable to decode query: ", T.pack (show bs), "\n" + ,"Specifically: ", T.pack decodeE + ] -- TODO to bencodable -- cgit v1.2.3 From fd62eb70fe87b471d29cb994a60ad88f58b33ca9 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 01:07:34 +0400 Subject: ~ Prepare to scheme check. --- examples/Server.hs | 2 +- src/Remote/KRPC.hs | 54 +++++++++++++++++++++++++++++---------------- src/Remote/KRPC/Method.hs | 22 +++++++++++++++++- src/Remote/KRPC/Protocol.hs | 17 +++++++------- 4 files changed, 65 insertions(+), 30 deletions(-) diff --git a/examples/Server.hs b/examples/Server.hs index 550bc344..8727c7d9 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -6,4 +6,4 @@ import Shared main :: IO () -main = server 6000 [undefined] +main = server 6000 [echoInt ==> return] diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 8f2027f2..22dbf3aa 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -10,6 +10,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} {-# LANGUAGE ExplicitForAll, KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} module Remote.KRPC ( module Remote.KRPC.Method, RemoteAddr @@ -17,7 +18,7 @@ module Remote.KRPC , call, async, await -- * Server - , server + , (==>), server ) where import Control.Exception @@ -27,6 +28,7 @@ import Control.Monad.IO.Class import Data.BEncode import Data.List as L import Data.Map as M +import Data.Set as S import Data.Text as T import Data.Typeable import Network @@ -51,6 +53,7 @@ queryCall sock addr m arg = sendMessage q addr sock where q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] +-- TODO check scheme getResult :: BEncodable result => KRemote -> KRemoteAddr -> Method param result -> IO result @@ -58,7 +61,7 @@ getResult sock addr m = do resp <- recvResponse addr sock case resp of Left e -> throw (RPCException e) - Right (KResponse dict) -> do + Right (respVals -> dict) -> do let valName = L.head (methodVals m) case M.lookup valName dict of Just val | Right res <- fromBEncode val -> return res @@ -102,10 +105,10 @@ async addr m arg = do await :: MonadIO host => Async result -> host result await = liftIO . waitResult --- TODO better name -type MHandler remote = ( Method BEncode (Result BEncode) - , BEncode -> remote (Result BEncode) - ) +type HandlerBody remote = (BEncode -> remote (Result BEncode), KResponseScheme) + +type MethodHandler remote = (KQueryScheme, HandlerBody remote) + -- we can safely erase types in (==>) (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). @@ -113,8 +116,8 @@ type MHandler remote = ( Method BEncode (Result BEncode) => Monad remote => Method param result -> (param -> remote result) - -> MHandler remote -m ==> body = undefined + -> MethodHandler remote +m ==> body = (methodQueryScheme m, (newbody, methodRespScheme m)) where newbody x = case fromBEncode x of Right a -> liftM (Right . toBEncode) (body a) @@ -125,15 +128,28 @@ m ==> body = undefined -- TODO: allow overloading server :: (MonadBaseControl IO remote, MonadIO remote) => PortNumber - -> [MHandler remote] + -> [MethodHandler remote] -> remote () -server servport ms = remoteServer servport $ \_ q -> do - let name = queryMethod q - let args = undefined -- queryArgs q - let m = L.head ms - res <- undefined -- methodBody m (snd (L.head (M.toList args))) - case res of - Left r -> return (Left (ProtocolError (T.pack r))) - Right r -> do - let retName = undefined -- L.head (methodVals m) - return (Right (kresponse [(retName, r)])) +server servport handlers = do + remoteServer servport $ \_ q -> do + case dispatch (scheme q) of + Nothing -> return (Left (MethodUnknown "method")) + Just (m, rsc) -> do + let arg = snd (L.head (M.toList (queryArgs q))) + + res <- invoke m arg + let valName = L.head (S.toList (rscVals rsc)) + return $ bimap (ProtocolError . T.pack) + (kresponse . return . (,) valName) res + where + handlerMap = M.fromList handlers + +-- dispatch :: KQueryScheme -> MethodHandler remote + dispatch s | Just m <- M.lookup s handlerMap = return m + | otherwise = Nothing + +-- invoke :: MethodHandler remote -> BEncode -> remote BEncode + invoke m args = m args + + bimap f _ (Left x) = Left (f x) + bimap _ g (Right x) = Right (g x) \ No newline at end of file diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index 3c757d07..420ceacf 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -1,6 +1,14 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- {-# LANGUAGE OverloadedStrings #-} module Remote.KRPC.Method ( Method(methodName, methodParams, methodVals) + , methodQueryScheme, methodRespScheme -- * Construction , method @@ -10,13 +18,16 @@ module Remote.KRPC.Method ) where import Prelude hiding ((.), id) +import Control.Applicative import Control.Category import Control.Monad +import Data.ByteString as B +import Data.List as L +import Data.Set as S import Remote.KRPC.Protocol - -- | The -- -- * argument: type of method parameter @@ -44,6 +55,15 @@ instance Category Method where (.) = composeM {-# INLINE (.) #-} +methodQueryScheme :: Method a b -> KQueryScheme +methodQueryScheme = KQueryScheme <$> B.intercalate "." . methodName + <*> S.fromList . methodParams +{-# INLINE methodQueryScheme #-} + + +methodRespScheme :: Method a b -> KResponseScheme +methodRespScheme = KResponseScheme . S.fromList . methodVals +{-# INLINE methodRespScheme #-} -- TODO ppMethod diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index e7fbea11..625aba25 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -24,12 +24,12 @@ module Remote.KRPC.Protocol , KError(..), errorCode, mkKError -- * Query - , KQuery(queryMethod, queryParams), MethodName, ParamName, kquery - , KQueryScheme(qscMethod, qscParams) + , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery + , KQueryScheme(KQueryScheme, qscMethod, qscParams) -- * Response , KResponse(respVals), ValName, kresponse - , KResponseScheme(rscVals) + , KResponseScheme(KResponseScheme, rscVals) , sendMessage, recvResponse @@ -46,12 +46,14 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control + import Data.BEncode import Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Map as M import Data.Set as S import Data.Text as T + import Network.Socket hiding (recvFrom) import Network.Socket.ByteString @@ -134,7 +136,7 @@ type ParamName = ByteString -- TODO document that it is and how transferred data KQuery = KQuery { queryMethod :: MethodName - , queryParams :: Map ParamName BEncode + , queryArgs :: Map ParamName BEncode } deriving (Show, Read, Eq, Ord) instance BEncodable KQuery where @@ -160,12 +162,9 @@ data KQueryScheme = KQueryScheme { , qscParams :: Set ParamName } deriving (Show, Read, Eq, Ord) -domen :: Map a b -> Set a -domen = error "scheme.domen" - instance KMessage KQuery KQueryScheme where {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} - scheme q = KQueryScheme (queryMethod q) (domen (queryParams q)) + scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) {-# INLINE scheme #-} type ValName = ByteString @@ -198,7 +197,7 @@ newtype KResponseScheme = KResponseScheme { instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . domen . respVals + scheme = KResponseScheme . keysSet . respVals {-# INLINE scheme #-} -- cgit v1.2.3 From e188c26f9e6b548b5170fb86f1bd4beee1f84708 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 04:47:45 +0400 Subject: + Multi param procedures. --- examples/Client.hs | 2 +- examples/Server.hs | 4 +-- examples/Shared.hs | 29 +++++++++++++++++- src/Remote/KRPC.hs | 75 +++++++++++++++++++++++++-------------------- src/Remote/KRPC/Method.hs | 61 ++++++++++++++++++++---------------- src/Remote/KRPC/Protocol.hs | 6 +++- 6 files changed, 112 insertions(+), 65 deletions(-) diff --git a/examples/Client.hs b/examples/Client.hs index bf486cb5..1d925c7a 100644 --- a/examples/Client.hs +++ b/examples/Client.hs @@ -10,7 +10,7 @@ addr :: RemoteAddr addr = (0, 6000) main :: IO () -main = print =<< call addr echoInt . read . head =<< getArgs +main = print =<< call addr swapM (1, 2) {- forM_ [1..] $ const $ do diff --git a/examples/Server.hs b/examples/Server.hs index 8727c7d9..3760b2ab 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE IncoherentInstances #-} module Main (main) where import Remote.KRPC @@ -6,4 +6,4 @@ import Shared main :: IO () -main = server 6000 [echoInt ==> return] +main = server 6000 [swapM ==> \(a, b) -> return (b, a)] diff --git a/examples/Shared.hs b/examples/Shared.hs index efe345ac..49cef490 100644 --- a/examples/Shared.hs +++ b/examples/Shared.hs @@ -1,6 +1,33 @@ -module Shared (echoInt) where +{-# LANGUAGE OverloadedStrings #-} +module Shared (echoInt, swapM) where import Remote.KRPC echoInt :: Method Int Int echoInt = idM + +swapM :: Method (Int, Int) (Int, Int) +swapM = method "swap" ["x", "y"] ["b", "a"] + +{- +type NodeId = Int +type InfoHashe = Int +type NodeAddr = Int +type Token = Int +type + +ping :: Method NodeId NodeId +ping = method "ping" ["id"] ["id"] + +find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) +find_node = method "find_node" ["id", "target"] ["id", "nodes"] + +get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) +get_peers = method "get_peers" + ("id", "target") + ("id", "token", view ("values" :|: "nodes")) +view :: BEncodable -> Maybe BEncodable +view = undefined +announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId +announce_peer = undefined +-} \ No newline at end of file diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 22dbf3aa..719b9a25 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -26,10 +26,12 @@ import Control.Monad import Control.Monad.Trans.Control import Control.Monad.IO.Class import Data.BEncode +import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M import Data.Set as S import Data.Text as T +import Data.Text.Encoding as T import Data.Typeable import Network @@ -47,14 +49,25 @@ type RemoteAddr = KRemoteAddr queryCall :: BEncodable param + => Extractable param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where - q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)] + q = kquery (methodName m) (mkVals (methodParams m) (injector arg)) + mkVals = L.zip + + +extractArgs :: [ParamName] -> Map ParamName BEncode -> Result [BEncode] +extractArgs as d = mapM f as + where + f x | Just y <- M.lookup x d = return y + | otherwise = Left ("not found key " ++ BC.unpack x) +{-# INLINE extractArgs #-} -- TODO check scheme getResult :: BEncodable result + => Extractable result => KRemote -> KRemoteAddr -> Method param result -> IO result getResult sock addr m = do @@ -62,15 +75,9 @@ getResult sock addr m = do case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do - let valName = L.head (methodVals m) - case M.lookup valName dict of - Just val | Right res <- fromBEncode val -> return res - Nothing -> throw (RPCException (ProtocolError msg)) - where - msg = T.concat - [ "Unable to find return value: ", T.pack (show valName), "\n" - , "in response: ", T.pack (show dict) - ] + case extractArgs (methodVals m) dict >>= extractor of + Right vals -> return vals + Left e -> throw (RPCException (ProtocolError (T.pack e))) -- TODO async call -- | Makes remote procedure call. Throws RPCException if server @@ -78,6 +85,7 @@ getResult sock addr m = do -- call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) + => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -92,6 +100,7 @@ newtype Async result = Async { waitResult :: IO result } -- TODO document errorneous usage async :: MonadIO host => (BEncodable param, BEncodable result) + => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -104,52 +113,50 @@ async addr m arg = do await :: MonadIO host => Async result -> host result await = liftIO . waitResult +{-# INLINE await #-} + -type HandlerBody remote = (BEncode -> remote (Result BEncode), KResponseScheme) +type HandlerBody remote = KQuery -> remote (Either KError KResponse) -type MethodHandler remote = (KQueryScheme, HandlerBody remote) +type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) + (BEncodable param, BEncodable result) + => (Extractable param, Extractable result) => Monad remote => Method param result -> (param -> remote result) -> MethodHandler remote -m ==> body = (methodQueryScheme m, (newbody, methodRespScheme m)) +{-# INLINE (==>) #-} +m ==> body = (methodName m, newbody) where - newbody x = case fromBEncode x of - Right a -> liftM (Right . toBEncode) (body a) - Left e -> return (Left e) + {-# INLINE newbody #-} + newbody q = + case extractArgs (methodParams m) (queryArgs q) >>= extractor of + Left e -> return (Left (ProtocolError (T.pack e))) + Right a -> do + r <- body a + return (Right (kresponse (mkVals (methodVals m) (injector r)))) + mkVals :: [ValName] -> [BEncode] -> [(ValName, BEncode)] + mkVals = L.zip -- TODO: allow forkIO --- TODO: allow overloading server :: (MonadBaseControl IO remote, MonadIO remote) => PortNumber -> [MethodHandler remote] -> remote () server servport handlers = do remoteServer servport $ \_ q -> do - case dispatch (scheme q) of - Nothing -> return (Left (MethodUnknown "method")) - Just (m, rsc) -> do - let arg = snd (L.head (M.toList (queryArgs q))) - - res <- invoke m arg - let valName = L.head (S.toList (rscVals rsc)) - return $ bimap (ProtocolError . T.pack) - (kresponse . return . (,) valName) res + case dispatch (queryMethod q) of + Nothing -> return $ Left $ MethodUnknown (decodeUtf8 (queryMethod q)) + Just m -> invoke m q where handlerMap = M.fromList handlers - --- dispatch :: KQueryScheme -> MethodHandler remote - dispatch s | Just m <- M.lookup s handlerMap = return m - | otherwise = Nothing - --- invoke :: MethodHandler remote -> BEncode -> remote BEncode - invoke m args = m args + dispatch s = M.lookup s handlerMap + invoke m q = m q bimap f _ (Left x) = Left (f x) bimap _ g (Right x) = Right (g x) \ No newline at end of file diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index 420ceacf..8aa6ddc9 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -6,6 +6,7 @@ -- Portability : portable -- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Remote.KRPC.Method ( Method(methodName, methodParams, methodVals) , methodQueryScheme, methodRespScheme @@ -14,13 +15,17 @@ module Remote.KRPC.Method , method -- * Predefined methods - , idM, composeM + , idM + + -- * Internal + , Extractable(..) ) where import Prelude hiding ((.), id) import Control.Applicative import Control.Category import Control.Monad +import Data.BEncode import Data.ByteString as B import Data.List as L import Data.Set as S @@ -38,7 +43,7 @@ import Remote.KRPC.Protocol -- data Method param result = Method { -- | Name used in query and - methodName :: [MethodName] + methodName :: MethodName -- | Description of each parameter in /right to left/ order. , methodParams :: [ParamName] @@ -46,17 +51,8 @@ data Method param result = Method { -- | Description of each return value in /right to left/ order. , methodVals :: [ValName] } - -instance Category Method where - {-# SPECIALIZE instance Category Method #-} - id = idM - {-# INLINE id #-} - - (.) = composeM - {-# INLINE (.) #-} - methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> B.intercalate "." . methodName +methodQueryScheme = KQueryScheme <$> methodName <*> S.fromList . methodParams {-# INLINE methodQueryScheme #-} @@ -75,19 +71,32 @@ idM :: Method a a idM = method "id" ["x"] ["y"] {-# INLINE idM #-} --- | Pipelining of two or more methods. --- --- NOTE: composed methods will work only with this implementation of --- KRPC, so both server and client should use this implementation, --- otherwise you more likely get the 'ProtocolError'. --- -composeM :: Method b c -> Method a b -> Method a c -composeM g h = Method (methodName g ++ methodName h) - (methodParams h) - (methodVals g) -{-# INLINE composeM #-} +method :: MethodName -> [ParamName] -> [ValName] -> Method param result +method = Method +{-# INLINE method #-} -method :: MethodName -> [ParamName] -> [ValName] -> Method param result -method name = Method [name] -{-# INLINE method #-} \ No newline at end of file + +class Extractable a where + injector :: a -> [BEncode] + extractor :: [BEncode] -> Result a + +instance (BEncodable a, BEncodable b) => Extractable (a, b) where + {- SPECIALIZE instance (BEncodable a, BEncodable b) => Extractable (a, b) -} + injector (a, b) = [toBEncode a, toBEncode b] + {-# INLINE injector #-} + + extractor [a, b] = (,) <$> fromBEncode a <*> fromBEncode b + extractor _ = decodingError "unable to match pair" + {-# INLINE extractor #-} +{- +instance BEncodable a => Extractable a where + {-# SPECIALIZE instance BEncodable a => Extractable a #-} + + injector x = [toBEncode x] + {-# INLINE injector #-} + + extractor [x] = fromBEncode x + extractor _ = decodingError "unable to match single value" + {-# INLINE extractor #-} +-} \ No newline at end of file diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 625aba25..98674c51 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -74,7 +74,7 @@ class KMessage message scheme | message -> scheme where validate = (==) . scheme {-# INLINE validate #-} - +-- TODO Text -> ByteString -- TODO document that it is and how transferred data KError -- | Some error doesn't fit in any other category. @@ -213,9 +213,13 @@ type KRemote = Socket withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) (liftIO . sClose) +{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} + maxMsgSize :: Int maxMsgSize = 16 * 1024 +{-# INLINE maxMsgSize #-} + -- TODO eliminate toStrict sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () -- cgit v1.2.3 From 250db0db86afe9462de1624a11e6b124c191d467 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 04:54:04 +0400 Subject: - Remove text dependency. --- krpc.cabal | 1 - src/Remote/KRPC.hs | 8 +++----- src/Remote/KRPC/Protocol.hs | 23 +++++++++-------------- 3 files changed, 12 insertions(+), 20 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index e62d0aa7..0c63711f 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -27,7 +27,6 @@ library , bytestring >= 0.10 , containers >= 0.4 - , text >= 0.11 , bencoding >= 0.1 , network >= 2.3 diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 719b9a25..fcfdf6bf 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -30,8 +30,6 @@ import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M import Data.Set as S -import Data.Text as T -import Data.Text.Encoding as T import Data.Typeable import Network @@ -77,7 +75,7 @@ getResult sock addr m = do Right (respVals -> dict) -> do case extractArgs (methodVals m) dict >>= extractor of Right vals -> return vals - Left e -> throw (RPCException (ProtocolError (T.pack e))) + Left e -> throw (RPCException (ProtocolError (BC.pack e))) -- TODO async call -- | Makes remote procedure call. Throws RPCException if server @@ -135,7 +133,7 @@ m ==> body = (methodName m, newbody) {-# INLINE newbody #-} newbody q = case extractArgs (methodParams m) (queryArgs q) >>= extractor of - Left e -> return (Left (ProtocolError (T.pack e))) + Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body a return (Right (kresponse (mkVals (methodVals m) (injector r)))) @@ -151,7 +149,7 @@ server :: (MonadBaseControl IO remote, MonadIO remote) server servport handlers = do remoteServer servport $ \_ q -> do case dispatch (queryMethod q) of - Nothing -> return $ Left $ MethodUnknown (decodeUtf8 (queryMethod q)) + Nothing -> return $ Left $ MethodUnknown (queryMethod q) Just m -> invoke m q where handlerMap = M.fromList handlers diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 98674c51..918bc735 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -49,10 +49,10 @@ import Control.Monad.Trans.Control import Data.BEncode import Data.ByteString as B +import Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB import Data.Map as M import Data.Set as S -import Data.Text as T import Network.Socket hiding (recvFrom) import Network.Socket.ByteString @@ -78,16 +78,16 @@ class KMessage message scheme | message -> scheme where -- TODO document that it is and how transferred data KError -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: Text } + = GenericError { errorMessage :: ByteString } -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: Text } + | ServerError { errorMessage :: ByteString } -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: Text } + | ProtocolError { errorMessage :: ByteString } -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: Text } + | MethodUnknown { errorMessage :: ByteString } deriving (Show, Read, Eq, Ord) instance BEncodable KError where @@ -116,7 +116,7 @@ errorCode (ProtocolError _) = 203 errorCode (MethodUnknown _) = 204 {-# INLINE errorCode #-} -mkKError :: ErrorCode -> Text -> KError +mkKError :: ErrorCode -> ByteString -> KError mkKError 201 = GenericError mkKError 202 = ServerError mkKError 203 = ProtocolError @@ -125,7 +125,7 @@ mkKError _ = GenericError {-# INLINE mkKError #-} serverError :: SomeException -> KError -serverError = ServerError . T.pack . show +serverError = ServerError . BC.pack . show -- TODO Asc everywhere @@ -238,7 +238,7 @@ recvResponse addr sock = do Right resp -> Right resp Left decE -> Left $ case decoded raw of Right kerror -> kerror - _ -> ProtocolError (T.pack decE) + _ -> ProtocolError (BC.pack decE) remoteServer :: (MonadBaseControl IO remote, MonadIO remote) @@ -265,12 +265,7 @@ remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop handleMsg bs addr = case decoded bs of Right query -> (either toBEncode toBEncode <$> action addr query) `catch` (return . toBEncode . serverError) - Left decodeE -> return $ toBEncode rpcE - where - rpcE = ProtocolError $ T.concat - ["Unable to decode query: ", T.pack (show bs), "\n" - ,"Specifically: ", T.pack decodeE - ] + Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) -- TODO to bencodable -- cgit v1.2.3 From ae555a1e49b7cbe606aac4f24a37200fd78ce90e Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 05:08:29 +0400 Subject: ~ Fix wall suggestions. --- src/Remote/KRPC.hs | 6 ++---- src/Remote/KRPC/Method.hs | 6 +----- src/Remote/KRPC/Protocol.hs | 6 +++--- 3 files changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index fcfdf6bf..a542f0b4 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -22,14 +22,12 @@ module Remote.KRPC ) where import Control.Exception -import Control.Monad import Control.Monad.Trans.Control import Control.Monad.IO.Class import Data.BEncode import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M -import Data.Set as S import Data.Typeable import Network @@ -121,8 +119,8 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) - => (Extractable param, Extractable result) +-- (BEncodable param, BEncodable result) + (Extractable param, Extractable result) => Monad remote => Method param result -> (param -> remote result) diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index 8aa6ddc9..d0c8e89a 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -21,13 +21,8 @@ module Remote.KRPC.Method , Extractable(..) ) where -import Prelude hiding ((.), id) import Control.Applicative -import Control.Category -import Control.Monad import Data.BEncode -import Data.ByteString as B -import Data.List as L import Data.Set as S import Remote.KRPC.Protocol @@ -89,6 +84,7 @@ instance (BEncodable a, BEncodable b) => Extractable (a, b) where extractor [a, b] = (,) <$> fromBEncode a <*> fromBEncode b extractor _ = decodingError "unable to match pair" {-# INLINE extractor #-} + {- instance BEncodable a => Extractable a where {-# SPECIALIZE instance BEncodable a => Extractable a #-} diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 918bc735..c922c1d6 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -97,8 +97,8 @@ instance BEncodable KError where ] fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "e") = - uncurry mkKError <$> d >-- "e" + | M.lookup "y" d == Just (BString "e") + = uncurry mkKError <$> d >-- "e" fromBEncode _ = decodingError "KError" @@ -278,4 +278,4 @@ instance (BEncodable a, BEncodable b) => BEncodable (a, b) where Right [a, b] -> (,) <$> fromBEncode a <*> fromBEncode b Right _ -> decodingError "Unable to decode a pair." Left e -> Left e - {-# INLINE fromBEncode #-} \ No newline at end of file + {-# INLINE fromBEncode #-} -- cgit v1.2.3 From ee8c82ed5ba8be43d858fa28020cc249d21795f6 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 05:25:15 +0400 Subject: - Remove bencodable instance for a pair. --- src/Remote/KRPC/Protocol.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index c922c1d6..7351831b 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -266,16 +266,3 @@ remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop Right query -> (either toBEncode toBEncode <$> action addr query) `catch` (return . toBEncode . serverError) Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) - - --- TODO to bencodable -instance (BEncodable a, BEncodable b) => BEncodable (a, b) where - {-# SPECIALIZE instance (BEncodable a, BEncodable b) => BEncodable (a, b) #-} - toBEncode (a, b) = BList [toBEncode a, toBEncode b] - {-# INLINE toBEncode #-} - - fromBEncode be = case fromBEncode be of - Right [a, b] -> (,) <$> fromBEncode a <*> fromBEncode b - Right _ -> decodingError "Unable to decode a pair." - Left e -> Left e - {-# INLINE fromBEncode #-} -- cgit v1.2.3 From 5ee611585e4eb6acb89b34e6679d89e25098e23b Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 06:46:58 +0400 Subject: - Remove Extractable class, fix multi param methods. --- examples/Client.hs | 7 ++++++- examples/Server.hs | 8 +++++++- examples/Shared.hs | 19 ++++++++++++++++--- src/Remote/KRPC.hs | 48 ++++++++++++++++++++++++----------------------- src/Remote/KRPC/Method.hs | 30 ----------------------------- 5 files changed, 54 insertions(+), 58 deletions(-) diff --git a/examples/Client.hs b/examples/Client.hs index 1d925c7a..cd340a03 100644 --- a/examples/Client.hs +++ b/examples/Client.hs @@ -10,7 +10,12 @@ addr :: RemoteAddr addr = (0, 6000) main :: IO () -main = print =<< call addr swapM (1, 2) +main = do + print =<< call addr unitM () + print =<< call addr echoM 0 + call addr reverseM [1..1000] + print =<< call addr swapM (0, 1) + print =<< call addr shiftR ((), 1, [2..10]) {- forM_ [1..] $ const $ do diff --git a/examples/Server.hs b/examples/Server.hs index 3760b2ab..0407c304 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -6,4 +6,10 @@ import Shared main :: IO () -main = server 6000 [swapM ==> \(a, b) -> return (b, a)] +main = server 6000 + [ unitM ==> return + , echoM ==> return + , swapM ==> \(a, b) -> return (b, a) + , reverseM ==> return . reverse + , shiftR ==> \(a, b, c) -> return (c, a, b) + ] diff --git a/examples/Shared.hs b/examples/Shared.hs index 49cef490..2d5b9cbb 100644 --- a/examples/Shared.hs +++ b/examples/Shared.hs @@ -1,14 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -module Shared (echoInt, swapM) where +module Shared + (echoM, unitM, swapM, reverseM, shiftR + ) where import Remote.KRPC -echoInt :: Method Int Int -echoInt = idM +unitM :: Method () () +unitM = method "unit" [] [] + +echoM :: Method Int Int +echoM = method "echo" ["x"] ["x"] + +reverseM :: Method [Int] [Int] +reverseM = method "reverse" ["xs"] ["ys"] swapM :: Method (Int, Int) (Int, Int) swapM = method "swap" ["x", "y"] ["b", "a"] +shiftR :: Method ((), Int, [Int]) ([Int], (), Int) +shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + + + {- type NodeId = Int type InfoHashe = Int diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index a542f0b4..5c1aadd6 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -21,6 +21,7 @@ module Remote.KRPC , (==>), server ) where +import Control.Applicative import Control.Exception import Control.Monad.Trans.Control import Control.Monad.IO.Class @@ -39,31 +40,39 @@ data RPCException = RPCException KError deriving (Show, Eq, Typeable) instance Exception RPCException +type RemoteAddr = KRemoteAddr +extractArgs :: BEncodable arg + => [ParamName] -> Map ParamName BEncode -> Result arg +extractArgs as d = fromBEncode =<< + case as of + [] -> Right (BList []) + [x] -> f x + xs -> BList <$> mapM f xs + where + f x = maybe (Left ("not found key " ++ BC.unpack x)) Right + (M.lookup x d) +{-# INLINE extractArgs #-} -type RemoteAddr = KRemoteAddr +injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] +injectVals [] (toBEncode -> BList []) = [] +injectVals [p] (toBEncode -> arg) = [(p, arg)] +injectVals ps (toBEncode -> BList as) = L.zip ps as +injectVals _ _ = error "KRPC.injectVals: impossible" +{-# INLINE injectVals #-} queryCall :: BEncodable param - => Extractable param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where - q = kquery (methodName m) (mkVals (methodParams m) (injector arg)) - mkVals = L.zip + q = kquery (methodName m) (injectVals (methodParams m) arg) -extractArgs :: [ParamName] -> Map ParamName BEncode -> Result [BEncode] -extractArgs as d = mapM f as - where - f x | Just y <- M.lookup x d = return y - | otherwise = Left ("not found key " ++ BC.unpack x) -{-# INLINE extractArgs #-} -- TODO check scheme getResult :: BEncodable result - => Extractable result => KRemote -> KRemoteAddr -> Method param result -> IO result getResult sock addr m = do @@ -71,7 +80,7 @@ getResult sock addr m = do case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do - case extractArgs (methodVals m) dict >>= extractor of + case extractArgs (methodVals m) dict of Right vals -> return vals Left e -> throw (RPCException (ProtocolError (BC.pack e))) @@ -81,7 +90,6 @@ getResult sock addr m = do -- call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) - => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -96,7 +104,6 @@ newtype Async result = Async { waitResult :: IO result } -- TODO document errorneous usage async :: MonadIO host => (BEncodable param, BEncodable result) - => (Extractable param, Extractable result) => RemoteAddr -> Method param result -> param @@ -119,8 +126,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). --- (BEncodable param, BEncodable result) - (Extractable param, Extractable result) + (BEncodable param, BEncodable result) => Monad remote => Method param result -> (param -> remote result) @@ -130,14 +136,13 @@ m ==> body = (methodName m, newbody) where {-# INLINE newbody #-} newbody q = - case extractArgs (methodParams m) (queryArgs q) >>= extractor of + case extractArgs (methodParams m) (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body a - return (Right (kresponse (mkVals (methodVals m) (injector r)))) + return (Right (kresponse (injectVals (methodVals m) r))) - mkVals :: [ValName] -> [BEncode] -> [(ValName, BEncode)] - mkVals = L.zip +infix 1 ==> -- TODO: allow forkIO server :: (MonadBaseControl IO remote, MonadIO remote) @@ -153,6 +158,3 @@ server servport handlers = do handlerMap = M.fromList handlers dispatch s = M.lookup s handlerMap invoke m q = m q - - bimap f _ (Left x) = Left (f x) - bimap _ g (Right x) = Right (g x) \ No newline at end of file diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index d0c8e89a..4283256b 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -16,9 +16,6 @@ module Remote.KRPC.Method -- * Predefined methods , idM - - -- * Internal - , Extractable(..) ) where import Control.Applicative @@ -69,30 +66,3 @@ idM = method "id" ["x"] ["y"] method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} - - - -class Extractable a where - injector :: a -> [BEncode] - extractor :: [BEncode] -> Result a - -instance (BEncodable a, BEncodable b) => Extractable (a, b) where - {- SPECIALIZE instance (BEncodable a, BEncodable b) => Extractable (a, b) -} - injector (a, b) = [toBEncode a, toBEncode b] - {-# INLINE injector #-} - - extractor [a, b] = (,) <$> fromBEncode a <*> fromBEncode b - extractor _ = decodingError "unable to match pair" - {-# INLINE extractor #-} - -{- -instance BEncodable a => Extractable a where - {-# SPECIALIZE instance BEncodable a => Extractable a #-} - - injector x = [toBEncode x] - {-# INLINE injector #-} - - extractor [x] = fromBEncode x - extractor _ = decodingError "unable to match single value" - {-# INLINE extractor #-} --} \ No newline at end of file -- cgit v1.2.3 From eff48f66c6d8e7231eef0ef3c3561e19865a2637 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 07:17:15 +0400 Subject: + Add basic bench. --- bench/Main.hs | 17 +++++++++++++++++ bench/Server.hs | 11 +++++++++++ krpc.cabal | 36 +++++++++++++++++++++++++----------- 3 files changed, 53 insertions(+), 11 deletions(-) create mode 100644 bench/Main.hs create mode 100644 bench/Server.hs diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 00000000..411282a0 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Criterion.Main +import Remote.KRPC + + +addr :: RemoteAddr +addr = (0, 6000) + +echo :: Method [Int] [Int] +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = defaultMain $ map mkbench [1, 10, 100, 1000] + where + mkbench n = bench (show n) $ nfIO $ call addr echo [1..n] \ No newline at end of file diff --git a/bench/Server.hs b/bench/Server.hs new file mode 100644 index 00000000..cb5ed316 --- /dev/null +++ b/bench/Server.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Remote.KRPC + + +echo :: Method [Int] [Int] +echo = method "echo" ["x"] ["x"] + +main :: IO () +main = server 6000 [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal index 0c63711f..97c903b9 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -13,6 +13,11 @@ bug-reports: https://github.com/pxqr/krpc/issues synopsis: KRPC remote procedure call protocol implementation. description: KRPC remote procedure call protocol implementation. +source-repository head + type: git + location: https://github.com/pxqr/krpc.git + + library exposed-modules: Remote.KRPC @@ -38,22 +43,31 @@ library -executable echo-client + +executable exsample-client main-is: Client.hs other-modules: Shared - - build-depends: base == 4.* - , krpc - + build-depends: base == 4.*, krpc hs-source-dirs: examples - - -executable echo-server +executable exsample-server main-is: Server.hs other-modules: Shared + build-depends: base == 4.*, krpc + hs-source-dirs: examples - build-depends: base == 4.* - , krpc - hs-source-dirs: examples + + +executable bench-server + main-is: Server.hs + build-depends: base == 4.*, krpc + hs-source-dirs: bench + ghc-options: -O2 + +benchmark bench-client + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + build-depends: base == 4.5.*, krpc, criterion + ghc-options: -O2 \ No newline at end of file -- cgit v1.2.3 From fafdbec2cb64f11513bfe3a0a220562de97d9e36 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 07:25:41 +0400 Subject: ~ Remove orphaned scheme validation. --- src/Remote/KRPC/Method.hs | 14 -------------- src/Remote/KRPC/Protocol.hs | 45 ++------------------------------------------- 2 files changed, 2 insertions(+), 57 deletions(-) diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs index 4283256b..4d91fe47 100644 --- a/src/Remote/KRPC/Method.hs +++ b/src/Remote/KRPC/Method.hs @@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Remote.KRPC.Method ( Method(methodName, methodParams, methodVals) - , methodQueryScheme, methodRespScheme -- * Construction , method @@ -18,10 +17,6 @@ module Remote.KRPC.Method , idM ) where -import Control.Applicative -import Data.BEncode -import Data.Set as S - import Remote.KRPC.Protocol @@ -43,15 +38,6 @@ data Method param result = Method { -- | Description of each return value in /right to left/ order. , methodVals :: [ValName] } -methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName - <*> S.fromList . methodParams -{-# INLINE methodQueryScheme #-} - - -methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . S.fromList . methodVals -{-# INLINE methodRespScheme #-} -- TODO ppMethod diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 7351831b..133c899a 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -17,19 +17,15 @@ {-# LANGUAGE DefaultSignatures #-} module Remote.KRPC.Protocol ( - -- * Message - KMessage(..) -- * Error - , KError(..), errorCode, mkKError + KError(..), errorCode, mkKError -- * Query , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery - , KQueryScheme(KQueryScheme, qscMethod, qscParams) -- * Response , KResponse(respVals), ValName, kresponse - , KResponseScheme(KResponseScheme, rscVals) , sendMessage, recvResponse @@ -52,28 +48,11 @@ import Data.ByteString as B import Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB import Data.Map as M -import Data.Set as S import Network.Socket hiding (recvFrom) import Network.Socket.ByteString - --- | Used to validate message by its scheme --- --- forall m. m `validate` scheme m --- -class KMessage message scheme | message -> scheme where - -- | Get a message scheme. - scheme :: message -> scheme - - -- | Check a message with a scheme. - validate :: message -> scheme -> Bool - - default validate :: Eq scheme => message -> scheme -> Bool - validate = (==) . scheme - {-# INLINE validate #-} - -- TODO Text -> ByteString -- TODO document that it is and how transferred data KError @@ -102,11 +81,6 @@ instance BEncodable KError where fromBEncode _ = decodingError "KError" -instance KMessage KError ErrorCode where - {-# SPECIALIZE instance KMessage KError ErrorCode #-} - scheme = errorCode - {-# INLINE scheme #-} - type ErrorCode = Int errorCode :: KError -> ErrorCode @@ -157,15 +131,8 @@ kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery kquery name args = KQuery name (M.fromList args) {-# INLINE kquery #-} -data KQueryScheme = KQueryScheme { - qscMethod :: MethodName - , qscParams :: Set ParamName - } deriving (Show, Read, Eq, Ord) -instance KMessage KQuery KQueryScheme where - {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} - scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) - {-# INLINE scheme #-} + type ValName = ByteString @@ -191,14 +158,6 @@ kresponse :: [(ValName, BEncode)] -> KResponse kresponse = KResponse . M.fromList {-# INLINE kresponse #-} -newtype KResponseScheme = KResponseScheme { - rscVals :: Set ValName - } deriving (Show, Read, Eq, Ord) - -instance KMessage KResponse KResponseScheme where - {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . keysSet . respVals - {-# INLINE scheme #-} type KRemoteAddr = (HostAddress, PortNumber) -- cgit v1.2.3 From a2bc26abbe6ccea464c04b990f8a4a8fa769ba2a Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 12 May 2013 07:31:58 +0400 Subject: ~ Move Method to KRPC. --- krpc.cabal | 1 - src/Remote/KRPC.hs | 45 ++++++++++++++++++++++++++++++++++++--- src/Remote/KRPC/Method.hs | 54 ----------------------------------------------- 3 files changed, 42 insertions(+), 58 deletions(-) delete mode 100644 src/Remote/KRPC/Method.hs diff --git a/krpc.cabal b/krpc.cabal index 97c903b9..e0fdb718 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -22,7 +22,6 @@ source-repository head library exposed-modules: Remote.KRPC , Remote.KRPC.Protocol - , Remote.KRPC.Method build-depends: base == 4.* diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 5c1aadd6..ec83b802 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -5,14 +5,20 @@ -- Stability : experimental -- Portability : portable -- --- This module provides remote procedure call. +-- This module provides safe remote procedure call. -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} {-# LANGUAGE ExplicitForAll, KindSignatures #-} {-# LANGUAGE ViewPatterns #-} module Remote.KRPC - ( module Remote.KRPC.Method, RemoteAddr + ( -- * Common + -- ** Types + RemoteAddr + + -- ** Method + , Method(methodName, methodParams, methodVals) + , method, idM -- * Client , call, async, await @@ -33,7 +39,40 @@ import Data.Typeable import Network import Remote.KRPC.Protocol -import Remote.KRPC.Method + + +-- | The +-- +-- * argument: type of method parameter +-- +-- * remote: A monad used by server-side. +-- +-- * result: type of return value of the method. +-- +data Method param result = Method { + -- | Name used in query and + methodName :: MethodName + + -- | Description of each parameter in /right to left/ order. + , methodParams :: [ParamName] + + -- | Description of each return value in /right to left/ order. + , methodVals :: [ValName] + } + +-- TODO ppMethod + +-- | Remote identity function. Could be used for echo servers for example. +-- +-- idM = method "id" ["x"] ["y"] return +-- +idM :: Method a a +idM = method "id" ["x"] ["y"] +{-# INLINE idM #-} + +method :: MethodName -> [ParamName] -> [ValName] -> Method param result +method = Method +{-# INLINE method #-} data RPCException = RPCException KError diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs deleted file mode 100644 index 4d91fe47..00000000 --- a/src/Remote/KRPC/Method.hs +++ /dev/null @@ -1,54 +0,0 @@ --- | --- Copyright : (c) Sam T. 2013 --- License : MIT --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} -module Remote.KRPC.Method - ( Method(methodName, methodParams, methodVals) - - -- * Construction - , method - - -- * Predefined methods - , idM - ) where - -import Remote.KRPC.Protocol - - --- | The --- --- * argument: type of method parameter --- --- * remote: A monad used by server-side. --- --- * result: type of return value of the method. --- -data Method param result = Method { - -- | Name used in query and - methodName :: MethodName - - -- | Description of each parameter in /right to left/ order. - , methodParams :: [ParamName] - - -- | Description of each return value in /right to left/ order. - , methodVals :: [ValName] - } - --- TODO ppMethod - --- | Remote identity function. Could be used for echo servers for example. --- --- idM = method "id" ["x"] ["y"] return --- -idM :: Method a a -idM = method "id" ["x"] ["y"] -{-# INLINE idM #-} - -method :: MethodName -> [ParamName] -> [ValName] -> Method param result -method = Method -{-# INLINE method #-} -- cgit v1.2.3 From d0038e9bde22751c9c926796a6c46be62a3cb81b Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:27:36 +0400 Subject: ~ Minor changes. --- bench/Main.hs | 11 ++++++++--- bench/Server.hs | 3 ++- examples/Client.hs | 4 ++++ examples/Server.hs | 1 + examples/Shared.hs | 6 +++++- krpc.cabal | 12 ++++++------ src/Remote/KRPC/Protocol.hs | 4 ++-- 7 files changed, 28 insertions(+), 13 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 411282a0..87d39f14 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Criterion.Main import Remote.KRPC @@ -8,10 +11,12 @@ import Remote.KRPC addr :: RemoteAddr addr = (0, 6000) -echo :: Method [Int] [Int] +echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = defaultMain $ map mkbench [1, 10, 100, 1000] +main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] + ++ map (mkbench 10) [1, 10, 100, 1000] where - mkbench n = bench (show n) $ nfIO $ call addr echo [1..n] \ No newline at end of file + mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ + replicateM r $ call addr echo (B.replicate n 0) \ No newline at end of file diff --git a/bench/Server.hs b/bench/Server.hs index cb5ed316..ece5a7a9 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Data.ByteString (ByteString) import Remote.KRPC -echo :: Method [Int] [Int] +echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () diff --git a/examples/Client.hs b/examples/Client.hs index cd340a03..ec86639e 100644 --- a/examples/Client.hs +++ b/examples/Client.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import qualified Data.ByteString as B import System.Environment import Remote.KRPC import Shared @@ -16,6 +17,9 @@ main = do call addr reverseM [1..1000] print =<< call addr swapM (0, 1) print =<< call addr shiftR ((), 1, [2..10]) + let bs = B.replicate (32 * 1024) 0 + bs' <- call addr echoBytes bs + print (bs == bs') {- forM_ [1..] $ const $ do diff --git a/examples/Server.hs b/examples/Server.hs index 0407c304..f636b0be 100644 --- a/examples/Server.hs +++ b/examples/Server.hs @@ -9,6 +9,7 @@ main :: IO () main = server 6000 [ unitM ==> return , echoM ==> return + , echoBytes ==> return , swapM ==> \(a, b) -> return (b, a) , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) diff --git a/examples/Shared.hs b/examples/Shared.hs index 2d5b9cbb..e0e5268c 100644 --- a/examples/Shared.hs +++ b/examples/Shared.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Shared - (echoM, unitM, swapM, reverseM, shiftR + (echoM, echoBytes, unitM, swapM, reverseM, shiftR ) where +import Data.ByteString (ByteString) import Remote.KRPC unitM :: Method () () @@ -11,6 +12,9 @@ unitM = method "unit" [] [] echoM :: Method Int Int echoM = method "echo" ["x"] ["x"] +echoBytes :: Method ByteString ByteString +echoBytes = method "echoBytes" ["x"] ["x"] + reverseM :: Method [Int] [Int] reverseM = method "reverse" ["xs"] ["ys"] diff --git a/krpc.cabal b/krpc.cabal index e0fdb718..b9bd0f1a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -46,13 +46,13 @@ library executable exsample-client main-is: Client.hs other-modules: Shared - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: examples executable exsample-server main-is: Server.hs other-modules: Shared - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: examples @@ -60,13 +60,13 @@ executable exsample-server executable bench-server main-is: Server.hs - build-depends: base == 4.*, krpc + build-depends: base == 4.*, krpc, bytestring hs-source-dirs: bench - ghc-options: -O2 + ghc-options: -O2 -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench - build-depends: base == 4.5.*, krpc, criterion - ghc-options: -O2 \ No newline at end of file + build-depends: base == 4.5.*, krpc, criterion, bytestring + ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 133c899a..29aaefed 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -6,7 +6,7 @@ -- Portability : portable -- -- This module provides straightforward implementation of KRPC --- protocol. In many situations Network.KRPC should be prefered +-- protocol. In many situations 'Network.KRPC' should be prefered -- since it gives more safe, convenient and high level api. -- -- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol @@ -176,7 +176,7 @@ withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) maxMsgSize :: Int -maxMsgSize = 16 * 1024 +maxMsgSize = 512 {-# INLINE maxMsgSize #-} -- cgit v1.2.3 From ab6ad1b5a10c46908a2c53a8148f5d202e517c7a Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:43:35 +0400 Subject: + Add documentation to KRPC module. --- src/Remote/KRPC.hs | 222 +++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 174 insertions(+), 48 deletions(-) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index ec83b802..0e9838f1 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -5,26 +5,101 @@ -- Stability : experimental -- Portability : portable -- --- This module provides safe remote procedure call. +-- This module provides safe remote procedure call. One important +-- point is exceptions and errors, so be able handle them properly +-- we need to investigate a bit about how this all works. +-- Internally, in order to make method invokation KRPC makes the +-- following steps: +-- +-- * Caller serialize arguments to bencoded bytestrings; +-- +-- * Caller send bytestring data over UDP to the callee; +-- +-- * Callee receive and decode arguments to the method and method +-- name. If it can't decode then it send 'ProtocolError' back to the +-- caller; +-- +-- * Callee search for the @method name@ in the method table. +-- If it not present in the table then callee send 'MethodUnknown' +-- back to the caller; +-- +-- * Callee check if argument names match. If not it send +-- 'ProtocolError' back; +-- +-- * Callee make the actuall call to the plain old haskell +-- function. If the function throw exception then callee send +-- 'ServerError' back. +-- +-- * Callee serialize result of the function to bencoded bytestring. +-- +-- * Callee encode result to bencoded bytestring and send it back +-- to the caller. +-- +-- * Caller check if return values names match with the signature +-- it called in the first step. +-- +-- * Caller extracts results and finally return results of the +-- procedure call as ordinary haskell values. +-- +-- If every other error occurred caller get the 'GenericError'. All +-- errors returned by callee are throwed as ordinary haskell +-- exceptions at caller side. Make sure that both callee and caller +-- uses the same method signatures and everything should be ok: this +-- KRPC implementation provides some level of safety through +-- types. Also note that both caller and callee use plain UDP, so +-- KRPC is unreliable. +-- +-- Consider one tiny example. From now @caller = client@ and +-- @callee = server or remote@. +-- +-- Somewhere we have to define all procedure signatures. Imagine +-- that this is a library shared between client and server: +-- +-- > factorialMethod :: Method Int Int +-- > factorialMethod = method "factorial" ["x"] ["y"] +-- +-- Otherwise you can define this code in both client and server of +-- course. But in this case you might get into troubles: you can get +-- 'MethodUnknown' or 'ProtocolError' if name or type of method +-- will mismatch after not synced changes in client or server code. +-- +-- Now let's define our client-side: +-- +-- > main = withRemote $ \remote -> do +-- > result <- call remote (0, 6000) factorialMethod 4 +-- > assert (result == 24) $ print "Success!" +-- +-- It basically open socket with 'withRemote' and make all the other +-- steps in 'call' as describe above. And finally our server-side: +-- +-- > factorialImpl :: Int -> Int +-- > factorialImpl n = product [1..n] +-- > +-- > main = runServer [factorialMethod $ return . factorialImpl] +-- +-- Here we implement method signature from that shared lib and run +-- server with runServer by passing method table in. +-- +-- For more examples see @exsamples@ or @tests@ directories. +-- +-- For protocol details see 'Remote.KRPC.Protocol' module. -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} {-# LANGUAGE ExplicitForAll, KindSignatures #-} {-# LANGUAGE ViewPatterns #-} module Remote.KRPC - ( -- * Common - -- ** Types - RemoteAddr - - -- ** Method - , Method(methodName, methodParams, methodVals) + ( -- * Method + Method(..) , method, idM -- * Client - , call, async, await + , RemoteAddr + , RPCException(..) + , call, Async, async, await -- * Server - , (==>), server + , MethodHandler, (==>), server ) where import Control.Applicative @@ -40,47 +115,58 @@ import Network import Remote.KRPC.Protocol - --- | The +-- | Method datatype used to describe name, parameters and return +-- values of procedure. Client use a method to /invoke/, server +-- /implements/ the method to make the actual work. -- --- * argument: type of method parameter +-- We use the following fantom types to ensure type-safiety: -- --- * remote: A monad used by server-side. +-- * param: Type of method parameters. Ordinary Tuple type used +-- to specify more than one parameter, so for example @Method +-- (Int, Int) result@ will take two arguments. -- --- * result: type of return value of the method. +-- * result: Type of return value of the method. Similarly, +-- tuple used to specify more than one return value, so for +-- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments +-- and return two values. -- data Method param result = Method { - -- | Name used in query and + -- | Name used in query. methodName :: MethodName - -- | Description of each parameter in /right to left/ order. + -- | Name of each parameter in /right to left/ order. , methodParams :: [ParamName] - -- | Description of each return value in /right to left/ order. + -- | Name of each return value in /right to left/ order. , methodVals :: [ValName] } -- TODO ppMethod --- | Remote identity function. Could be used for echo servers for example. +-- | Identity procedure signature. Could be used for echo +-- servers. Implemented as: -- --- idM = method "id" ["x"] ["y"] return +-- > idM = method "id" ["x"] ["y"] -- idM :: Method a a idM = method "id" ["x"] ["y"] {-# INLINE idM #-} +-- | Makes method signature. Note that order of parameters and return +-- values are not important as long as corresponding names and types +-- are match. For exsample this is the equal definitions: +-- +-- > methodA : Method (Foo, Bar) (Baz, Quux) +-- > methodA = method "mymethod" ["a", "b"] ["c", "d"] +-- +-- > methodA : Method (Bar, Foo) (Quux, Baz) +-- > methodB = method "mymethod" ["b", "a"] ["d", "c"] +-- method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} -data RPCException = RPCException KError - deriving (Show, Eq, Typeable) - -instance Exception RPCException -type RemoteAddr = KRemoteAddr - extractArgs :: BEncodable arg => [ParamName] -> Map ParamName BEncode -> Result arg extractArgs as d = fromBEncode =<< @@ -101,6 +187,19 @@ injectVals _ _ = error "KRPC.injectVals: impossible" {-# INLINE injectVals #-} + +-- | Represent any error mentioned by protocol specification that +-- 'call', 'await' might throw. +-- For more details see 'Remote.KRPC.Protocol'. +-- +data RPCException = RPCException KError + deriving (Show, Eq, Typeable) + +instance Exception RPCException + +-- | Address of remote can be called by client. +type RemoteAddr = KRemoteAddr + queryCall :: BEncodable param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () @@ -108,9 +207,6 @@ queryCall sock addr m arg = sendMessage q addr sock where q = kquery (methodName m) (injectVals (methodParams m) arg) - - --- TODO check scheme getResult :: BEncodable result => KRemote -> KRemoteAddr -> Method param result -> IO result @@ -123,53 +219,78 @@ getResult sock addr m = do Right vals -> return vals Left e -> throw (RPCException (ProtocolError (BC.pack e))) --- TODO async call --- | Makes remote procedure call. Throws RPCException if server --- returns error or decode error occurred. --- + +-- | Makes remote procedure call. Throws RPCException on any error +-- occurred. call :: (MonadBaseControl IO host, MonadIO host) => (BEncodable param, BEncodable result) - => RemoteAddr - -> Method param result - -> param - -> host result + => RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. call addr m arg = liftIO $ withRemote $ \sock -> do queryCall sock addr m arg getResult sock addr m +-- | Asynchonous result typically get from 'async' call. Used to defer +-- return values transfer. newtype Async result = Async { waitResult :: IO result } --- TODO document errorneous usage + +-- | Query procedure call but not wait for its results. This function +-- returns 'Async' value which is handle to procedure result. Actual +-- result might be obtained with 'await'. Unable to throw +-- 'RPCException', this might happen in 'await' if at all. +-- +-- Note that sending multiple queries at the same time to the one +-- remote is not recommended. For exsample in the following scenario: +-- +-- > aa <- async theRemote .... +-- > ab <- async theRemote .... +-- > a <- await ab +-- > b <- await ab +-- +-- it's likely that the /a/ and /b/ values will be mixed up. So in +-- order to get correct results you need to make 'await' before the +-- next 'async'. +-- async :: MonadIO host => (BEncodable param, BEncodable result) - => RemoteAddr - -> Method param result - -> param - -> host (Async result) + => RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host (Async result) -- ^ Handle to result. async addr m arg = do liftIO $ withRemote $ \sock -> queryCall sock addr m arg return $ Async $ withRemote $ \sock -> getResult sock addr m -await :: MonadIO host => Async result -> host result +-- | Will wait until the callee finished processing of procedure call +-- and return its results. Throws 'RPCException' on any error +-- occurred. +await :: MonadIO host + => Async result -- ^ Obtained from the corresponding 'async'. + -> host result -- ^ Result values of the procedure call quered + -- with 'async'. await = liftIO . waitResult {-# INLINE await #-} type HandlerBody remote = KQuery -> remote (Either KError KResponse) +-- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) - -- we can safely erase types in (==>) +-- | Assign method implementation to the method signature. (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). (BEncodable param, BEncodable result) => Monad remote - => Method param result - -> (param -> remote result) - -> MethodHandler remote + => Method param result -- ^ Signature. + -> (param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. {-# INLINE (==>) #-} m ==> body = (methodName m, newbody) where @@ -184,9 +305,14 @@ m ==> body = (methodName m, newbody) infix 1 ==> -- TODO: allow forkIO + +-- | Run RPC server on specified port by using list of handlers. +-- Server will dispatch procedure specified by callee, but note that +-- it will not create new thread for each connection. +-- server :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber - -> [MethodHandler remote] + => PortNumber -- ^ Port used to accept incoming connections. + -> [MethodHandler remote] -- ^ Method table. -> remote () server servport handlers = do remoteServer servport $ \_ q -> do -- cgit v1.2.3 From 7c18b3fb5077c43aca7b728649108fda901ba236 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:45:40 +0400 Subject: + Added readme. --- README.md | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 00000000..bf9a28de --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +# Synopsis + +KRPC is simple remote procedure call mechanism used by bittorrent DHT +but might be used anywhere else. + +# Description + +KRPC basically consisting of bencoded dictionraies sent over UDP. This +implementation provides extra safiety by separation of procedure +signature | implementation and baking procedure type in host +language, thus it's hard to shoot yourself in the foot accidently. + +See bittorrent DHT [specification][spec] for detailed protocol +description. + +## Modules + +* Remote.KRPC — simple interface which reduce all RPC related stuff to + a few lines. Should be used in the first place. + +* Remote.KRPC.Protocol — raw protocol implementation. + +# Documentation + +For usage see examples in ```examples``` directory. +For documentation see haddock generated documentation. + +# Build Status + +[![Build Status][status-img]][status-link] + +# Authors + +This library is written and maintained by Sam T. +Feel free to report bugs and suggestions via github issue tracker or the mail. + +[spec]: http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol +[status-img]: https://travis-ci.org/pxqr/krpc.png +[status-link]: https://travis-ci.org/pxqr/krpc -- cgit v1.2.3 From e8ce2092f9738072ddee1a677b5c6e8923f8627e Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:46:18 +0400 Subject: ~ Fix typo. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index bf9a28de..b94c7967 100644 --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ but might be used anywhere else. # Description -KRPC basically consisting of bencoded dictionraies sent over UDP. This +KRPC basically consisting of bencoded dictionaries sent over UDP. This implementation provides extra safiety by separation of procedure signature | implementation and baking procedure type in host language, thus it's hard to shoot yourself in the foot accidently. -- cgit v1.2.3 From 50490ccb9ac98dc03a499972e693da8514779be6 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 10:57:25 +0400 Subject: ~ Move exsamples to tests. --- examples/Client.hs | 27 --------------------------- examples/Server.hs | 16 ---------------- examples/Shared.hs | 50 -------------------------------------------------- tests/Client.hs | 27 +++++++++++++++++++++++++++ tests/Server.hs | 16 ++++++++++++++++ tests/Shared.hs | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 93 insertions(+), 93 deletions(-) delete mode 100644 examples/Client.hs delete mode 100644 examples/Server.hs delete mode 100644 examples/Shared.hs create mode 100644 tests/Client.hs create mode 100644 tests/Server.hs create mode 100644 tests/Shared.hs diff --git a/examples/Client.hs b/examples/Client.hs deleted file mode 100644 index ec86639e..00000000 --- a/examples/Client.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import qualified Data.ByteString as B -import System.Environment -import Remote.KRPC -import Shared - - -addr :: RemoteAddr -addr = (0, 6000) - -main :: IO () -main = do - print =<< call addr unitM () - print =<< call addr echoM 0 - call addr reverseM [1..1000] - print =<< call addr swapM (0, 1) - print =<< call addr shiftR ((), 1, [2..10]) - let bs = B.replicate (32 * 1024) 0 - bs' <- call addr echoBytes bs - print (bs == bs') - -{- - forM_ [1..] $ const $ do - async addr myconcat (replicate 100 [1..10]) --} diff --git a/examples/Server.hs b/examples/Server.hs deleted file mode 100644 index f636b0be..00000000 --- a/examples/Server.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} -module Main (main) where - -import Remote.KRPC -import Shared - - -main :: IO () -main = server 6000 - [ unitM ==> return - , echoM ==> return - , echoBytes ==> return - , swapM ==> \(a, b) -> return (b, a) - , reverseM ==> return . reverse - , shiftR ==> \(a, b, c) -> return (c, a, b) - ] diff --git a/examples/Shared.hs b/examples/Shared.hs deleted file mode 100644 index e0e5268c..00000000 --- a/examples/Shared.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Shared - (echoM, echoBytes, unitM, swapM, reverseM, shiftR - ) where - -import Data.ByteString (ByteString) -import Remote.KRPC - -unitM :: Method () () -unitM = method "unit" [] [] - -echoM :: Method Int Int -echoM = method "echo" ["x"] ["x"] - -echoBytes :: Method ByteString ByteString -echoBytes = method "echoBytes" ["x"] ["x"] - -reverseM :: Method [Int] [Int] -reverseM = method "reverse" ["xs"] ["ys"] - -swapM :: Method (Int, Int) (Int, Int) -swapM = method "swap" ["x", "y"] ["b", "a"] - -shiftR :: Method ((), Int, [Int]) ([Int], (), Int) -shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] - - - -{- -type NodeId = Int -type InfoHashe = Int -type NodeAddr = Int -type Token = Int -type - -ping :: Method NodeId NodeId -ping = method "ping" ["id"] ["id"] - -find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) -find_node = method "find_node" ["id", "target"] ["id", "nodes"] - -get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) -get_peers = method "get_peers" - ("id", "target") - ("id", "token", view ("values" :|: "nodes")) -view :: BEncodable -> Maybe BEncodable -view = undefined -announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId -announce_peer = undefined --} \ No newline at end of file diff --git a/tests/Client.hs b/tests/Client.hs new file mode 100644 index 00000000..ec86639e --- /dev/null +++ b/tests/Client.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.ByteString as B +import System.Environment +import Remote.KRPC +import Shared + + +addr :: RemoteAddr +addr = (0, 6000) + +main :: IO () +main = do + print =<< call addr unitM () + print =<< call addr echoM 0 + call addr reverseM [1..1000] + print =<< call addr swapM (0, 1) + print =<< call addr shiftR ((), 1, [2..10]) + let bs = B.replicate (32 * 1024) 0 + bs' <- call addr echoBytes bs + print (bs == bs') + +{- + forM_ [1..] $ const $ do + async addr myconcat (replicate 100 [1..10]) +-} diff --git a/tests/Server.hs b/tests/Server.hs new file mode 100644 index 00000000..f636b0be --- /dev/null +++ b/tests/Server.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE IncoherentInstances #-} +module Main (main) where + +import Remote.KRPC +import Shared + + +main :: IO () +main = server 6000 + [ unitM ==> return + , echoM ==> return + , echoBytes ==> return + , swapM ==> \(a, b) -> return (b, a) + , reverseM ==> return . reverse + , shiftR ==> \(a, b, c) -> return (c, a, b) + ] diff --git a/tests/Shared.hs b/tests/Shared.hs new file mode 100644 index 00000000..e0e5268c --- /dev/null +++ b/tests/Shared.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +module Shared + (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ) where + +import Data.ByteString (ByteString) +import Remote.KRPC + +unitM :: Method () () +unitM = method "unit" [] [] + +echoM :: Method Int Int +echoM = method "echo" ["x"] ["x"] + +echoBytes :: Method ByteString ByteString +echoBytes = method "echoBytes" ["x"] ["x"] + +reverseM :: Method [Int] [Int] +reverseM = method "reverse" ["xs"] ["ys"] + +swapM :: Method (Int, Int) (Int, Int) +swapM = method "swap" ["x", "y"] ["b", "a"] + +shiftR :: Method ((), Int, [Int]) ([Int], (), Int) +shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + + + +{- +type NodeId = Int +type InfoHashe = Int +type NodeAddr = Int +type Token = Int +type + +ping :: Method NodeId NodeId +ping = method "ping" ["id"] ["id"] + +find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) +find_node = method "find_node" ["id", "target"] ["id", "nodes"] + +get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) +get_peers = method "get_peers" + ("id", "target") + ("id", "token", view ("values" :|: "nodes")) +view :: BEncodable -> Maybe BEncodable +view = undefined +announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId +announce_peer = undefined +-} \ No newline at end of file -- cgit v1.2.3 From dca81a23bcec19ab7562322c2eb988b286afe944 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 12:01:47 +0400 Subject: + Add hunit tests. --- bench/Main.hs | 7 ++++++- krpc.cabal | 24 +++++++++++++++++------- tests/Client.hs | 53 +++++++++++++++++++++++++++++++++++++++-------------- 3 files changed, 62 insertions(+), 22 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 87d39f14..f9650d97 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -19,4 +19,9 @@ main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] ++ map (mkbench 10) [1, 10, 100, 1000] where mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call addr echo (B.replicate n 0) \ No newline at end of file + replicateM r $ call addr echo (B.replicate n 0) + +{- + forM_ [1..] $ const $ do + async addr myconcat (replicate 100 [1..10]) +-} diff --git a/krpc.cabal b/krpc.cabal index b9bd0f1a..bb3fdea6 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -42,18 +42,28 @@ library - -executable exsample-client +test-suite test-client + type: exitcode-stdio-1.0 main-is: Client.hs other-modules: Shared - build-depends: base == 4.*, krpc, bytestring - hs-source-dirs: examples + build-depends: base == 4.* + , bytestring + , krpc + + , HUnit + , test-framework + , test-framework-hunit -executable exsample-server + hs-source-dirs: tests + +executable test-server main-is: Server.hs other-modules: Shared - build-depends: base == 4.*, krpc, bytestring - hs-source-dirs: examples + build-depends: base == 4.* + , bytestring + , krpc + + hs-source-dirs: tests diff --git a/tests/Client.hs b/tests/Client.hs index ec86639e..c2ac6d01 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -3,6 +3,11 @@ module Main (main) where import qualified Data.ByteString as B import System.Environment + +import Test.HUnit hiding (Test) +import Test.Framework +import Test.Framework.Providers.HUnit + import Remote.KRPC import Shared @@ -11,17 +16,37 @@ addr :: RemoteAddr addr = (0, 6000) main :: IO () -main = do - print =<< call addr unitM () - print =<< call addr echoM 0 - call addr reverseM [1..1000] - print =<< call addr swapM (0, 1) - print =<< call addr shiftR ((), 1, [2..10]) - let bs = B.replicate (32 * 1024) 0 - bs' <- call addr echoBytes bs - print (bs == bs') - -{- - forM_ [1..] $ const $ do - async addr myconcat (replicate 100 [1..10]) --} +main = defaultMain tests + +(==?) :: (Eq a, Show a) => a -> IO a -> Assertion +expected ==? action = do + actual <- action + expected @=? actual + +tests :: [Test] +tests = + [ testCase "unit" $ + () ==? call addr unitM () + + , testCase "echo int" $ + 1234 ==? call addr echoM 1234 + + , testCase "reverse 1..100" $ + reverse [1..100] ==? call addr reverseM [1..100] + + , testCase "reverse empty list" $ + reverse [] ==? call addr reverseM [] + + , testCase "reverse singleton list" $ + reverse [1] ==? call addr reverseM [1] + + , testCase "swap pair" $ + (1, 0) ==? call addr swapM (0, 1) + + , testCase "shift triple" $ + ([2..10], (), 1) ==? call addr shiftR ((), 1, [2..10]) + + , testCase "echo bytestring" $ + let bs = B.replicate 400 0 in + bs ==? call addr echoBytes bs + ] -- cgit v1.2.3 From 0d11413c087536e34999c3d2295cace55600af4a Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 14 May 2013 14:37:06 +0400 Subject: ~ Expose some functions. --- bench/Main.hs | 16 +++++++++++++--- src/Remote/KRPC.hs | 29 ++++++++++++++++++++++------- src/Remote/KRPC/Protocol.hs | 15 ++++++--------- 3 files changed, 41 insertions(+), 19 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index f9650d97..ed0d5a35 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -15,12 +15,22 @@ echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = defaultMain $ map (mkbench 1) [1, 10, 100, 1000, 32 * 1024] - ++ map (mkbench 10) [1, 10, 100, 1000] +main = withRemote $ \remote -> do { + ; let sizes = [10, 100, 1000, 10000, 16 * 1024] + ; let repetitions = [1, 10, 100, 1000] + ; let params = [(r, s) | r <- repetitions, s <- sizes] + ; let benchmarks = (concatMap (\(a, b) -> [a, b]) $ zip + (map (uncurry (mkbench remote)) params) + (map (uncurry (mkbench_ remote)) params)) + ; defaultMain benchmarks + } where - mkbench r n = bench (show r ++ "/" ++ show n) $ nfIO $ + mkbench _ r n = bench (show r ++ "/" ++ show n) $ nfIO $ replicateM r $ call addr echo (B.replicate n 0) + mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ + replicateM r $ call_ re addr echo (B.replicate n 0) + {- forM_ [1..] $ const $ do async addr myconcat (replicate 100 [1..10]) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 0e9838f1..e1ad0853 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -100,6 +100,10 @@ module Remote.KRPC -- * Server , MethodHandler, (==>), server + + -- * Internal + , call_ + , withRemote ) where import Control.Applicative @@ -186,7 +190,8 @@ injectVals ps (toBEncode -> BList as) = L.zip ps as injectVals _ _ = error "KRPC.injectVals: impossible" {-# INLINE injectVals #-} - +-- | Alias to Socket, through might change in future. +type Remote = Socket -- | Represent any error mentioned by protocol specification that -- 'call', 'await' might throw. @@ -208,10 +213,10 @@ queryCall sock addr m arg = sendMessage q addr sock q = kquery (methodName m) (injectVals (methodParams m) arg) getResult :: BEncodable result - => KRemote -> KRemoteAddr + => KRemote -> Method param result -> IO result -getResult sock addr m = do - resp <- recvResponse addr sock +getResult sock m = do + resp <- recvResponse sock case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do @@ -228,9 +233,19 @@ call :: (MonadBaseControl IO host, MonadIO host) -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. -> host result -- ^ Values returned by callee from the procedure. -call addr m arg = liftIO $ withRemote $ \sock -> do +call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg + +-- | The same as 'call' but use already opened socket. +call_ :: (MonadBaseControl IO host, MonadIO host) + => (BEncodable param, BEncodable result) + => Remote -- ^ Socket to use + -> RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call_ sock addr m arg = liftIO $ do queryCall sock addr m arg - getResult sock addr m + getResult sock m -- | Asynchonous result typically get from 'async' call. Used to defer @@ -265,7 +280,7 @@ async addr m arg = do liftIO $ withRemote $ \sock -> queryCall sock addr m arg return $ Async $ withRemote $ \sock -> - getResult sock addr m + getResult sock m -- | Will wait until the callee finished processing of procedure call -- and return its results. Throws 'RPCException' on any error diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 29aaefed..3f3b16d0 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -162,11 +162,6 @@ kresponse = KResponse . M.fromList type KRemoteAddr = (HostAddress, PortNumber) -remoteAddr :: KRemoteAddr -> SockAddr -remoteAddr = SockAddrInet <$> snd <*> fst -{-# INLINE remoteAddr #-} - - type KRemote = Socket withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a @@ -176,8 +171,11 @@ withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) maxMsgSize :: Int -maxMsgSize = 512 {-# INLINE maxMsgSize #-} +-- release +--maxMsgSize = 512 -- size of payload of one udp packet +-- bench +maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict @@ -189,9 +187,8 @@ sendMessage msg (host, port) sock = -- TODO check scheme -recvResponse :: KRemoteAddr -> KRemote -> IO (Either KError KResponse) -recvResponse addr sock = do - connect sock (remoteAddr addr) +recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize return $ case decoded raw of Right resp -> Right resp -- cgit v1.2.3 From 835854192f3b49b9abca0827df5c7c81d9ec0a75 Mon Sep 17 00:00:00 2001 From: Sam T Date: Wed, 15 May 2013 18:46:33 +0400 Subject: - Remove some useless comments. --- tests/Shared.hs | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/tests/Shared.hs b/tests/Shared.hs index e0e5268c..bf29365b 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -23,28 +23,3 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] - - - -{- -type NodeId = Int -type InfoHashe = Int -type NodeAddr = Int -type Token = Int -type - -ping :: Method NodeId NodeId -ping = method "ping" ["id"] ["id"] - -find_node :: Method (NodeId, NodeId) (NodeId, NodeAddr) -find_node = method "find_node" ["id", "target"] ["id", "nodes"] - -get_peers :: Method (NodeId :*: InfoHash) (NodeId, Token, NodeAddr :|: NodeAddr) -get_peers = method "get_peers" - ("id", "target") - ("id", "token", view ("values" :|: "nodes")) -view :: BEncodable -> Maybe BEncodable -view = undefined -announce_peer :: Method (NodeId, InfoHash, PortNumber, Token) NodeId -announce_peer = undefined --} \ No newline at end of file -- cgit v1.2.3 From ca6065e694d14fe579363f8b24e509062f02d070 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 06:28:49 +0400 Subject: ~ Add travis config file. --- .travis.yml | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..2e65e0e1 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,10 @@ +language: haskell + +notifications: + email: false + +install: + cabal install --only-dependencies --enable-tests --force-reinstalls + +script: + cabal configure --enable-tests --enable-benchmark && cabal build && cabal test \ No newline at end of file -- cgit v1.2.3 From 50d5ea27eaef30af27b839dcc2bc1305a904c94e Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 06:34:53 +0400 Subject: ~ Fix travis install script. --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 2e65e0e1..0d6ef5ee 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,9 @@ notifications: email: false install: - cabal install --only-dependencies --enable-tests --force-reinstalls + - git clone https://github.com/pxqr/bencoding.git + - cd bencoding && cabal install --force-reinstalls && cd .. + - cabal install --only-dependencies --enable-tests --force-reinstalls script: cabal configure --enable-tests --enable-benchmark && cabal build && cabal test \ No newline at end of file -- cgit v1.2.3 From c22a4f2a7cbb11c4904c3c9796335d1b34f3c601 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 06:41:09 +0400 Subject: ~ Fix travis install script. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 0d6ef5ee..8d22afa9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ notifications: install: - git clone https://github.com/pxqr/bencoding.git - cd bencoding && cabal install --force-reinstalls && cd .. - - cabal install --only-dependencies --enable-tests --force-reinstalls + - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls script: cabal configure --enable-tests --enable-benchmark && cabal build && cabal test \ No newline at end of file -- cgit v1.2.3 From 3093d1ffb375b70e125bba4aacefa03d56d094c6 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 07:31:40 +0400 Subject: ~ Run server from test client. --- krpc.cabal | 3 +++ tests/Client.hs | 18 +++++++++++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index bb3fdea6..446c612d 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -48,6 +48,9 @@ test-suite test-client other-modules: Shared build-depends: base == 4.* , bytestring + , process + , filepath + , krpc , HUnit diff --git a/tests/Client.hs b/tests/Client.hs index c2ac6d01..d762976d 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -1,8 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Concurrent +import Control.Exception import qualified Data.ByteString as B import System.Environment +import System.Process +import System.FilePath import Test.HUnit hiding (Test) import Test.Framework @@ -15,8 +19,20 @@ import Shared addr :: RemoteAddr addr = (0, 6000) +withServ :: FilePath -> IO () -> IO () +withServ serv_path = bracket up terminateProcess . const + where + up = do + (_, _, _, h) <- createProcess (proc serv_path []) + threadDelay 1000000 + return h + main :: IO () -main = defaultMain tests +main = do + let serv_path = "dist" "build" "test-server" "test-server" + withServ serv_path $ + defaultMain tests + (==?) :: (Eq a, Show a) => a -> IO a -> Assertion expected ==? action = do -- cgit v1.2.3 From 10a36a068d0595336c14a754073f33595a859758 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 08:13:48 +0400 Subject: ~ Return scheme validation back. --- krpc.cabal | 1 + src/Remote/KRPC/Protocol.hs | 2 +- src/Remote/KRPC/Scheme.hs | 68 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 src/Remote/KRPC/Scheme.hs diff --git a/krpc.cabal b/krpc.cabal index 446c612d..474778ad 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -22,6 +22,7 @@ source-repository head library exposed-modules: Remote.KRPC , Remote.KRPC.Protocol + , Remote.KRPC.Scheme build-depends: base == 4.* diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 3f3b16d0..36a1e38a 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -19,7 +19,7 @@ module Remote.KRPC.Protocol ( -- * Error - KError(..), errorCode, mkKError + KError(..), ErrorCode, errorCode, mkKError -- * Query , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs new file mode 100644 index 00000000..84982649 --- /dev/null +++ b/src/Remote/KRPC/Scheme.hs @@ -0,0 +1,68 @@ +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides message scheme validation for core protocol +-- messages from 'Remote.KRPC.Procotol'. This module should be used +-- with 'Remote.KRPC.Protocol', otherwise (if you use 'Remote.KRPC') +-- this module seems to be useless. +-- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +module Remote.KRPC.Scheme + ( KMessage(..) + , KQueryScheme(..) + , KResponseScheme(..) + ) where + +import Data.Map as M +import Data.Set + +import Remote.KRPC.Protocol + + +-- | Used to validate any message by its scheme +-- +-- forall m. m `validate` scheme m +-- +class KMessage message scheme | message -> scheme where + -- | Get a message scheme. + scheme :: message -> scheme + + -- | Check a message with a scheme. + validate :: message -> scheme -> Bool + + default validate :: Eq scheme => message -> scheme -> Bool + validate = (==) . scheme + {-# INLINE validate #-} + + +instance KMessage KError ErrorCode where + {-# SPECIALIZE instance KMessage KError ErrorCode #-} + scheme = errorCode + {-# INLINE scheme #-} + + +data KQueryScheme = KQueryScheme { + qscMethod :: MethodName + , qscParams :: Set ParamName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KQuery KQueryScheme where + {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} + scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) + {-# INLINE scheme #-} + + +newtype KResponseScheme = KResponseScheme { + rscVals :: Set ValName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KResponse KResponseScheme where + {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} + scheme = KResponseScheme . keysSet . respVals + {-# INLINE scheme #-} \ No newline at end of file -- cgit v1.2.3 From 71333831b3da64bee6030e537f4aba1c1c4b73e2 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 08:18:37 +0400 Subject: + Add method scheme extraction. --- src/Remote/KRPC/Scheme.hs | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs index 84982649..378883bb 100644 --- a/src/Remote/KRPC/Scheme.hs +++ b/src/Remote/KRPC/Scheme.hs @@ -7,7 +7,7 @@ -- -- This module provides message scheme validation for core protocol -- messages from 'Remote.KRPC.Procotol'. This module should be used --- with 'Remote.KRPC.Protocol', otherwise (if you use 'Remote.KRPC') +-- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') -- this module seems to be useless. -- {-# LANGUAGE DefaultSignatures #-} @@ -15,14 +15,16 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} module Remote.KRPC.Scheme ( KMessage(..) - , KQueryScheme(..) - , KResponseScheme(..) + , KQueryScheme(..), methodQueryScheme + , KResponseScheme(..), methodRespScheme ) where +import Control.Applicative import Data.Map as M -import Data.Set +import Data.Set as S import Remote.KRPC.Protocol +import Remote.KRPC -- | Used to validate any message by its scheme @@ -57,6 +59,11 @@ instance KMessage KQuery KQueryScheme where scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) {-# INLINE scheme #-} +methodQueryScheme :: Method a b -> KQueryScheme +methodQueryScheme = KQueryScheme <$> methodName + <*> S.fromList . methodParams +{-# INLINE methodQueryScheme #-} + newtype KResponseScheme = KResponseScheme { rscVals :: Set ValName @@ -65,4 +72,8 @@ newtype KResponseScheme = KResponseScheme { instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} scheme = KResponseScheme . keysSet . respVals - {-# INLINE scheme #-} \ No newline at end of file + {-# INLINE scheme #-} + +methodRespScheme :: Method a b -> KResponseScheme +methodRespScheme = KResponseScheme . S.fromList . methodVals +{-# INLINE methodRespScheme #-} -- cgit v1.2.3 From 179351029766b6003db50758fbfd61488f56eb51 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 08:50:59 +0400 Subject: ~ Document message types --- src/Remote/KRPC/Protocol.hs | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 36a1e38a..4fbe517c 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -53,8 +53,14 @@ import Network.Socket hiding (recvFrom) import Network.Socket.ByteString --- TODO Text -> ByteString --- TODO document that it is and how transferred +-- | Errors used to signal that some error occurred while processing a +-- procedure call. Error may be send only from server to client but +-- not in the opposite direction. +-- +-- Errors are encoded as bencoded dictionary: +-- +-- { "y" : "e", "e" : [, ] } +-- data KError -- | Some error doesn't fit in any other category. = GenericError { errorMessage :: ByteString } @@ -107,7 +113,14 @@ serverError = ServerError . BC.pack . show type MethodName = ByteString type ParamName = ByteString --- TODO document that it is and how transferred +-- | Query used to signal that caller want to make procedure call to +-- callee and pass arguments in. Therefore query may be only sent from +-- client to server but not in the opposite direction. +-- +-- Queries are encoded as bencoded dictionary: +-- +-- { "y" : "q", "q" : "", "a" : [, , ...] } +-- data KQuery = KQuery { queryMethod :: MethodName , queryArgs :: Map ParamName BEncode @@ -136,7 +149,15 @@ kquery name args = KQuery name (M.fromList args) type ValName = ByteString --- TODO document that it is and how transferred +-- | KResponse used to signal that callee successufully process a +-- procedure call and to return values from procedure. KResponse should +-- not be sent if error occurred during RPC. Thus KResponse may be only +-- sent from server to client. +-- +-- Responses are encoded as bencoded dictionary: +-- +-- { "y" : "r", "r" : [, , ...] } +-- newtype KResponse = KResponse { respVals :: Map ValName BEncode } deriving (Show, Read, Eq, Ord) -- cgit v1.2.3 From 6cb9b41f6f8752bd58abeaefa0e855c3b6221cc1 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 08:57:04 +0400 Subject: ~ Minor changes. --- src/Remote/KRPC/Protocol.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 4fbe517c..45ce2bb0 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -206,8 +206,6 @@ sendMessage msg (host, port) sock = {-# INLINE sendMessage #-} {-# SPECIALIZE sendMessage :: BEncode -> KRemoteAddr -> KRemote -> IO () #-} - --- TODO check scheme recvResponse :: KRemote -> IO (Either KError KResponse) recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize @@ -217,10 +215,11 @@ recvResponse sock = do Right kerror -> kerror _ -> ProtocolError (BC.pack decE) - +-- | Run server using a given port. Method invocation should be done manually. remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber + => PortNumber -- ^ Port number to listen. -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) + -- ^ Handler. -> remote () remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop where -- cgit v1.2.3 From 8a18d0d510bef4284688dfc6c9b7209983d1d193 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 09:12:18 +0400 Subject: ~ Remove duplicated benchmarks. --- bench/Main.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index ed0d5a35..697ecce9 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -19,15 +19,10 @@ main = withRemote $ \remote -> do { ; let sizes = [10, 100, 1000, 10000, 16 * 1024] ; let repetitions = [1, 10, 100, 1000] ; let params = [(r, s) | r <- repetitions, s <- sizes] - ; let benchmarks = (concatMap (\(a, b) -> [a, b]) $ zip - (map (uncurry (mkbench remote)) params) - (map (uncurry (mkbench_ remote)) params)) + ; let benchmarks = map (uncurry (mkbench_ remote)) params ; defaultMain benchmarks } where - mkbench _ r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call addr echo (B.replicate n 0) - mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ replicateM r $ call_ re addr echo (B.replicate n 0) -- cgit v1.2.3 From b77691e022600e7eef6f933c1d52831f732ec606 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 19 May 2013 09:37:51 +0400 Subject: ~ Make use fromAscAssocs. --- src/Remote/KRPC/Protocol.hs | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 45ce2bb0..462f72eb 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -76,11 +76,14 @@ data KError deriving (Show, Read, Eq, Ord) instance BEncodable KError where - toBEncode e = fromAssocs - [ "y" --> ("e" :: ByteString) - , "e" --> (errorCode e, errorMessage e) + {-# SPECIALIZE instance BEncodable KError #-} + {-# INLINE toBEncode #-} + toBEncode e = fromAscAssocs -- WARN: keep keys sorted + [ "e" --> (errorCode e, errorMessage e) + , "y" --> ("e" :: ByteString) ] + {-# INLINE fromBEncode #-} fromBEncode (BDict d) | M.lookup "y" d == Just (BString "e") = uncurry mkKError <$> d >-- "e" @@ -127,12 +130,15 @@ data KQuery = KQuery { } deriving (Show, Read, Eq, Ord) instance BEncodable KQuery where - toBEncode (KQuery m args) = fromAssocs - [ "y" --> ("q" :: ByteString) + {-# SPECIALIZE instance BEncodable KQuery #-} + {-# INLINE toBEncode #-} + toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted + [ "a" --> BDict args , "q" --> m - , "a" --> BDict args + , "y" --> ("q" :: ByteString) ] + {-# INLINE fromBEncode #-} fromBEncode (BDict d) | M.lookup "y" d == Just (BString "q") = KQuery <$> d >-- "q" @@ -163,11 +169,14 @@ newtype KResponse = KResponse { } deriving (Show, Read, Eq, Ord) instance BEncodable KResponse where - toBEncode (KResponse vals) = fromAssocs - [ "y" --> ("r" :: ByteString) - , "r" --> vals + {-# SPECIALIZE instance BEncodable KResponse #-} + {-# INLINE toBEncode #-} + toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted + [ "r" --> vals + , "y" --> ("r" :: ByteString) ] + {-# INLINE fromBEncode #-} fromBEncode (BDict d) | M.lookup "y" d == Just (BString "r") = KResponse <$> d >-- "r" -- cgit v1.2.3 From d77b247832973a8c2cb780f31ba034de45c4613f Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 27 May 2013 04:10:31 +0400 Subject: ~ Update readme. --- README.md | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index b94c7967..3e8e84a5 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,9 @@ -# Synopsis +### Synopsis KRPC is simple remote procedure call mechanism used by bittorrent DHT but might be used anywhere else. -# Description +### Description KRPC basically consisting of bencoded dictionaries sent over UDP. This implementation provides extra safiety by separation of procedure @@ -13,23 +13,24 @@ language, thus it's hard to shoot yourself in the foot accidently. See bittorrent DHT [specification][spec] for detailed protocol description. -## Modules +### Modules * Remote.KRPC — simple interface which reduce all RPC related stuff to a few lines. Should be used in the first place. * Remote.KRPC.Protocol — raw protocol implementation. +* Remote.KRPC.Scheme — message validation. -# Documentation +### Documentation For usage see examples in ```examples``` directory. For documentation see haddock generated documentation. -# Build Status +### Build Status [![Build Status][status-img]][status-link] -# Authors +### Maintainer This library is written and maintained by Sam T. Feel free to report bugs and suggestions via github issue tracker or the mail. -- cgit v1.2.3 From 3d799406a530231807b13bf893328aa3ef13ea44 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 27 May 2013 04:12:11 +0400 Subject: ~ Fix readme. --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 3e8e84a5..88731915 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ language, thus it's hard to shoot yourself in the foot accidently. See bittorrent DHT [specification][spec] for detailed protocol description. -### Modules +#### Modules * Remote.KRPC — simple interface which reduce all RPC related stuff to a few lines. Should be used in the first place. @@ -33,6 +33,7 @@ For documentation see haddock generated documentation. ### Maintainer This library is written and maintained by Sam T. + Feel free to report bugs and suggestions via github issue tracker or the mail. [spec]: http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol -- cgit v1.2.3 From 5538be6787e3dc7ce149b2a5c65339cb7c4cb02f Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 9 Jun 2013 22:35:18 +0400 Subject: ~ Prepare for Hackage. --- README.md | 2 +- krpc.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 88731915..9b34c81c 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ but might be used anywhere else. KRPC basically consisting of bencoded dictionaries sent over UDP. This implementation provides extra safiety by separation of procedure -signature | implementation and baking procedure type in host +signature and implementation and baking procedure type in host language, thus it's hard to shoot yourself in the foot accidently. See bittorrent DHT [specification][spec] for detailed protocol diff --git a/krpc.cabal b/krpc.cabal index 474778ad..d9dc8880 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -5,7 +5,7 @@ license-file: LICENSE author: Sam T. maintainer: Sam T. copyright: (c) 2013, Sam T. -category: Network, Remote +category: Network build-type: Simple cabal-version: >=1.8 homepage: https://github.com/pxqr/krpc @@ -15,7 +15,7 @@ description: KRPC remote procedure call protocol implementation. source-repository head type: git - location: https://github.com/pxqr/krpc.git + location: git://github.com/pxqr/krpc.git @@ -76,7 +76,7 @@ executable bench-server main-is: Server.hs build-depends: base == 4.*, krpc, bytestring hs-source-dirs: bench - ghc-options: -O2 -fforce-recomp + ghc-options: -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 -- cgit v1.2.3 From bbd7e81df12a15c588e1b38627983e8bddc42367 Mon Sep 17 00:00:00 2001 From: Sam T Date: Sun, 9 Jun 2013 22:37:00 +0400 Subject: ~ Add release notes section. --- krpc.cabal | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index d9dc8880..78a4aaeb 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -11,7 +11,14 @@ cabal-version: >=1.8 homepage: https://github.com/pxqr/krpc bug-reports: https://github.com/pxqr/krpc/issues synopsis: KRPC remote procedure call protocol implementation. -description: KRPC remote procedure call protocol implementation. +description: + + KRPC remote procedure call protocol implementation. + . + [/Release Notes/] + . + * /0.1.0.0:/ Initial version. + source-repository head type: git -- cgit v1.2.3 From 2be391c59deb670fd8084c6bd0fa9c2cbe2fd5cf Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 21:03:55 +0400 Subject: ~ Add test case, fix cabal. --- krpc.cabal | 5 +++-- tests/Client.hs | 4 ++++ tests/Server.hs | 2 ++ tests/Shared.hs | 12 +++++++++++- 4 files changed, 20 insertions(+), 3 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 78a4aaeb..54746433 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -43,7 +43,6 @@ library , network >= 2.3 - hs-source-dirs: src extensions: PatternGuards ghc-options: -Wall @@ -59,6 +58,7 @@ test-suite test-client , process , filepath + , bencoding , krpc , HUnit @@ -72,6 +72,7 @@ executable test-server other-modules: Shared build-depends: base == 4.* , bytestring + , bencoding , krpc hs-source-dirs: tests @@ -89,5 +90,5 @@ benchmark bench-client type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench - build-depends: base == 4.5.*, krpc, criterion, bytestring + build-depends: base == 4.*, krpc, criterion, bytestring ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/tests/Client.hs b/tests/Client.hs index d762976d..1b9ef8d2 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -4,6 +4,7 @@ module Main (main) where import Control.Concurrent import Control.Exception import qualified Data.ByteString as B +import Data.BEncode import System.Environment import System.Process import System.FilePath @@ -65,4 +66,7 @@ tests = , testCase "echo bytestring" $ let bs = B.replicate 400 0 in bs ==? call addr echoBytes bs + + , testCase "raw method" $ + BInteger 10 ==? call addr rawM (BInteger 10) ] diff --git a/tests/Server.hs b/tests/Server.hs index f636b0be..7cd6a5d6 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE IncoherentInstances #-} module Main (main) where +import Data.BEncode import Remote.KRPC import Shared @@ -13,4 +14,5 @@ main = server 6000 , swapM ==> \(a, b) -> return (b, a) , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) + , rawM ==> return ] diff --git a/tests/Shared.hs b/tests/Shared.hs index bf29365b..a04b6093 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -1,9 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Shared - (echoM, echoBytes, unitM, swapM, reverseM, shiftR + ( echoM + , echoBytes + , unitM + , swapM + , reverseM + , shiftR + , rawM ) where import Data.ByteString (ByteString) +import Data.BEncode import Remote.KRPC unitM :: Method () () @@ -23,3 +30,6 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] + +rawM :: Method BEncode BEncode +rawM = method "rawM" [""] [""] \ No newline at end of file -- cgit v1.2.3 From a437e18badb78bd4946ce4ecec830acdf000abee Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 21:15:19 +0400 Subject: ~ Fix GHC 7.6.3 warnings. --- krpc.cabal | 2 ++ src/Remote/KRPC/Protocol.hs | 10 ++++------ 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 54746433..059f6348 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -8,6 +8,8 @@ copyright: (c) 2013, Sam T. category: Network build-type: Simple cabal-version: >=1.8 +tested-with: GHC == 7.4.1 + , GHC == 7.6.3 homepage: https://github.com/pxqr/krpc bug-reports: https://github.com/pxqr/krpc/issues synopsis: KRPC remote procedure call protocol implementation. diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 462f72eb..2e41bb2e 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -36,9 +36,8 @@ module Remote.KRPC.Protocol , encode, encoded, decode, decoded, toBEncode, fromBEncode ) where -import Prelude hiding (catch) import Control.Applicative -import Control.Exception.Lifted +import Control.Exception.Lifted as Lifted import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control @@ -213,7 +212,6 @@ sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () sendMessage msg (host, port) sock = sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) {-# INLINE sendMessage #-} -{-# SPECIALIZE sendMessage :: BEncode -> KRemoteAddr -> KRemote -> IO () #-} recvResponse :: KRemote -> IO (Either KError KResponse) recvResponse sock = do @@ -230,9 +228,9 @@ remoteServer :: (MonadBaseControl IO remote, MonadIO remote) -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) -- ^ Handler. -> remote () -remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop +remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop where - bind = do + bindServ = do sock <- socket AF_INET Datagram defaultProtocol bindSocket sock (SockAddrInet servport iNADDR_ANY) return sock @@ -249,5 +247,5 @@ remoteServer servport action = bracket (liftIO bind) (liftIO . sClose) loop where handleMsg bs addr = case decoded bs of Right query -> (either toBEncode toBEncode <$> action addr query) - `catch` (return . toBEncode . serverError) + `Lifted.catch` (return . toBEncode . serverError) Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) -- cgit v1.2.3 From 76b4937c99f131bbe52ef22b03a0bb7317280257 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 22:34:16 +0400 Subject: ~ Allow passing raw dictionaries. We need this in Kademlia DHT -- there are method which return dictionaries with different keys depending on DHT server state. --- krpc.cabal | 1 + src/Remote/KRPC.hs | 18 +++++++++++++++--- tests/Client.hs | 8 ++++++++ tests/Server.hs | 1 + tests/Shared.hs | 6 +++++- 5 files changed, 30 insertions(+), 4 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 059f6348..779d7abc 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -57,6 +57,7 @@ test-suite test-client other-modules: Shared build-depends: base == 4.* , bytestring + , containers , process , filepath diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index e1ad0853..1b4ae4b6 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -175,7 +175,9 @@ extractArgs :: BEncodable arg => [ParamName] -> Map ParamName BEncode -> Result arg extractArgs as d = fromBEncode =<< case as of - [] -> Right (BList []) + [] -> if M.null d + then Right (BList []) + else Right (BDict d) [x] -> f x xs -> BList <$> mapM f xs where @@ -184,12 +186,22 @@ extractArgs as d = fromBEncode =<< {-# INLINE extractArgs #-} injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] -injectVals [] (toBEncode -> BList []) = [] +injectVals [] (toBEncode -> be) + = case be of + BList [] -> [] + BDict d -> M.toList d + _ -> invalidParamList [] be + injectVals [p] (toBEncode -> arg) = [(p, arg)] injectVals ps (toBEncode -> BList as) = L.zip ps as -injectVals _ _ = error "KRPC.injectVals: impossible" +injectVals pl a = invalidParamList pl (toBEncode a) {-# INLINE injectVals #-} +invalidParamList :: [ParamName] -> BEncode -> a +invalidParamList pl be + = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ + "while procedure args are: " ++ show be + -- | Alias to Socket, through might change in future. type Remote = Socket diff --git a/tests/Client.hs b/tests/Client.hs index 1b9ef8d2..313cd56e 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -5,6 +5,7 @@ import Control.Concurrent import Control.Exception import qualified Data.ByteString as B import Data.BEncode +import Data.Map import System.Environment import System.Process import System.FilePath @@ -69,4 +70,11 @@ tests = , testCase "raw method" $ BInteger 10 ==? call addr rawM (BInteger 10) + + , testCase "raw dict" $ + let dict = BDict $ fromList + [ ("some_int", BInteger 100) + , ("some_list", BList [BInteger 10]) + ] + in dict ==? call addr rawDictM dict ] diff --git a/tests/Server.hs b/tests/Server.hs index 7cd6a5d6..aaf6d9f2 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -15,4 +15,5 @@ main = server 6000 , reverseM ==> return . reverse , shiftR ==> \(a, b, c) -> return (c, a, b) , rawM ==> return + , rawDictM ==> return ] diff --git a/tests/Shared.hs b/tests/Shared.hs index a04b6093..f64112da 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -7,6 +7,7 @@ module Shared , reverseM , shiftR , rawM + , rawDictM ) where import Data.ByteString (ByteString) @@ -32,4 +33,7 @@ shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] rawM :: Method BEncode BEncode -rawM = method "rawM" [""] [""] \ No newline at end of file +rawM = method "rawM" [""] [""] + +rawDictM :: Method BEncode BEncode +rawDictM = method "m" [] [] \ No newline at end of file -- cgit v1.2.3 From e8dc0c6087738dc6e08298e3c108d8d61fd92a10 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 23:49:49 +0400 Subject: ~ Code style. --- src/Remote/KRPC.hs | 43 +++++++++++++++++-------------------------- 1 file changed, 17 insertions(+), 26 deletions(-) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 1b4ae4b6..74842db6 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -170,31 +170,22 @@ method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} +lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode +lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x -extractArgs :: BEncodable arg - => [ParamName] -> Map ParamName BEncode -> Result arg -extractArgs as d = fromBEncode =<< - case as of - [] -> if M.null d - then Right (BList []) - else Right (BDict d) - [x] -> f x - xs -> BList <$> mapM f xs - where - f x = maybe (Left ("not found key " ++ BC.unpack x)) Right - (M.lookup x d) +extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode +extractArgs [] d = Right $ if M.null d then BList [] else BDict d +extractArgs [x] d = lookupKey x d +extractArgs xs d = BList <$> mapM (`lookupKey` d) xs {-# INLINE extractArgs #-} -injectVals :: BEncodable arg => [ParamName] -> arg -> [(ParamName, BEncode)] -injectVals [] (toBEncode -> be) - = case be of - BList [] -> [] - BDict d -> M.toList d - _ -> invalidParamList [] be - -injectVals [p] (toBEncode -> arg) = [(p, arg)] -injectVals ps (toBEncode -> BList as) = L.zip ps as -injectVals pl a = invalidParamList pl (toBEncode a) +injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] +injectVals [] (BList []) = [] +injectVals [] (BDict d ) = M.toList d +injectVals [] be = invalidParamList [] be +injectVals [p] arg = [(p, arg)] +injectVals ps (BList as) = L.zip ps as +injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} invalidParamList :: [ParamName] -> BEncode -> a @@ -222,7 +213,7 @@ queryCall :: BEncodable param -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where - q = kquery (methodName m) (injectVals (methodParams m) arg) + q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) getResult :: BEncodable result => KRemote @@ -232,7 +223,7 @@ getResult sock m = do case resp of Left e -> throw (RPCException e) Right (respVals -> dict) -> do - case extractArgs (methodVals m) dict of + case fromBEncode =<< extractArgs (methodVals m) dict of Right vals -> return vals Left e -> throw (RPCException (ProtocolError (BC.pack e))) @@ -323,11 +314,11 @@ m ==> body = (methodName m, newbody) where {-# INLINE newbody #-} newbody q = - case extractArgs (methodParams m) (queryArgs q) of + case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body a - return (Right (kresponse (injectVals (methodVals m) r))) + return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) infix 1 ==> -- cgit v1.2.3 From e097ec428c7334d0b25dc4fcbf3b82a58e79fa62 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 23:52:51 +0400 Subject: ~ Prettify extensions lists. --- src/Remote/KRPC.hs | 10 ++++++---- src/Remote/KRPC/Protocol.hs | 10 ++++++---- src/Remote/KRPC/Scheme.hs | 7 ++++--- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 74842db6..cca8342f 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -84,10 +84,12 @@ -- -- For protocol details see 'Remote.KRPC.Protocol' module. -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll, KindSignatures #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} module Remote.KRPC ( -- * Method Method(..) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 2e41bb2e..0cbb041d 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -11,10 +11,12 @@ -- -- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} module Remote.KRPC.Protocol ( diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs index 378883bb..1cf970ea 100644 --- a/src/Remote/KRPC/Scheme.hs +++ b/src/Remote/KRPC/Scheme.hs @@ -10,9 +10,10 @@ -- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') -- this module seems to be useless. -- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} module Remote.KRPC.Scheme ( KMessage(..) , KQueryScheme(..), methodQueryScheme -- cgit v1.2.3 From 5ab0dce7258346db69f501f0ffb8bd90aed45e84 Mon Sep 17 00:00:00 2001 From: Sam T Date: Mon, 8 Jul 2013 23:58:03 +0400 Subject: + Document raw dictionaries passing. --- src/Remote/KRPC.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index cca8342f..485327e1 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -136,6 +136,13 @@ import Remote.KRPC.Protocol -- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments -- and return two values. -- +-- To pass raw dictionaries you should specify empty param list: +-- +-- > method "my_method" [] [] :: Method BEncode BEncode +-- +-- In this case you should handle dictionary extraction by hand, both +-- in client and server. +-- data Method param result = Method { -- | Name used in query. methodName :: MethodName -- cgit v1.2.3 From f55c684b641a4fa593ce0f124f06401ddc0b5487 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 9 Jul 2013 00:40:03 +0400 Subject: + .ghci --- .ghci | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 .ghci diff --git a/.ghci b/.ghci new file mode 100644 index 00000000..0c692119 --- /dev/null +++ b/.ghci @@ -0,0 +1,3 @@ +import Control.Concurrent +import Data.BEncode +import Network -- cgit v1.2.3 From 329f0951e38bd6b04347a7d46710392fe7b18c8e Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 9 Jul 2013 00:40:37 +0400 Subject: ~ Fix documentation markup. --- src/Remote/KRPC/Protocol.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 0cbb041d..a569066f 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -60,7 +60,7 @@ import Network.Socket.ByteString -- -- Errors are encoded as bencoded dictionary: -- --- { "y" : "e", "e" : [, ] } +-- > { "y" : "e", "e" : [, ] } -- data KError -- | Some error doesn't fit in any other category. @@ -123,7 +123,7 @@ type ParamName = ByteString -- -- Queries are encoded as bencoded dictionary: -- --- { "y" : "q", "q" : "", "a" : [, , ...] } +-- > { "y" : "q", "q" : "", "a" : [, , ...] } -- data KQuery = KQuery { queryMethod :: MethodName @@ -163,7 +163,7 @@ type ValName = ByteString -- -- Responses are encoded as bencoded dictionary: -- --- { "y" : "r", "r" : [, , ...] } +-- > { "y" : "r", "r" : [, , ...] } -- newtype KResponse = KResponse { respVals :: Map ValName BEncode -- cgit v1.2.3 From 4f97f2d8671cea0bcc5582c58d2257516e71889f Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 9 Jul 2013 00:42:02 +0400 Subject: ~ Bump version. --- krpc.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 779d7abc..4ea2ca02 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.1.0.0 +version: 0.1.1.0 license: MIT license-file: LICENSE author: Sam T. @@ -20,7 +20,8 @@ description: [/Release Notes/] . * /0.1.0.0:/ Initial version. - + . + * /0.1.1.0:/ Allow passing raw argument\/result dictionaries. source-repository head type: git -- cgit v1.2.3 From a2c9210d0a1e55f4b24564a8654bda8dc5fdaaed Mon Sep 17 00:00:00 2001 From: Sam T Date: Sat, 10 Aug 2013 08:09:38 +0400 Subject: ~ Update urls. --- .travis.yml | 2 +- README.md | 4 ++-- krpc.cabal | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8d22afa9..8cb74db1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ notifications: email: false install: - - git clone https://github.com/pxqr/bencoding.git + - git clone https://github.com/cobit/bencoding.git - cd bencoding && cabal install --force-reinstalls && cd .. - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls diff --git a/README.md b/README.md index 9b34c81c..18a7242e 100644 --- a/README.md +++ b/README.md @@ -37,5 +37,5 @@ This library is written and maintained by Sam T. Feel free to report bugs and suggestions via github issue tracker or the mail. [spec]: http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol -[status-img]: https://travis-ci.org/pxqr/krpc.png -[status-link]: https://travis-ci.org/pxqr/krpc +[status-img]: https://travis-ci.org/cobit/krpc.png +[status-link]: https://travis-ci.org/cobit/krpc diff --git a/krpc.cabal b/krpc.cabal index 4ea2ca02..45b3346a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -10,8 +10,8 @@ build-type: Simple cabal-version: >=1.8 tested-with: GHC == 7.4.1 , GHC == 7.6.3 -homepage: https://github.com/pxqr/krpc -bug-reports: https://github.com/pxqr/krpc/issues +homepage: https://github.com/cobit/krpc +bug-reports: https://github.com/cobit/krpc/issues synopsis: KRPC remote procedure call protocol implementation. description: @@ -25,7 +25,7 @@ description: source-repository head type: git - location: git://github.com/pxqr/krpc.git + location: git://github.com/cobit/krpc.git -- cgit v1.2.3 From d23955e0684a575dca6d40dda46583ba9c1d285a Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 00:26:39 +0400 Subject: + Move TODO list to repository. --- TODO.org | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 TODO.org diff --git a/TODO.org b/TODO.org new file mode 100644 index 00000000..fc8ad395 --- /dev/null +++ b/TODO.org @@ -0,0 +1,14 @@ +* DONE document protocol +* DONE Ascending everywhere +* DONE document KRPC module +* DONE move exsamples to tests +* DONE make HUnit tests +* DONE run server in test automatically +* DONE use one socket everywhere +* DONE fix performance issues +* DONE add readme +* DONE return scheme back +* TODO add show instance for method +* TODO hide async api +* TODO expose client addr in server-side +* TODO major version bump (reason: exported type changed) -- cgit v1.2.3 From 2627337f24574cda88b905a3b8df8bbf43604d6a Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 00:33:05 +0400 Subject: ~ Adapt package for newer version of cabal. --- krpc.cabal | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 45b3346a..ab8d8f77 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -7,7 +7,7 @@ maintainer: Sam T. copyright: (c) 2013, Sam T. category: Network build-type: Simple -cabal-version: >=1.8 +cabal-version: >= 1.10 tested-with: GHC == 7.4.1 , GHC == 7.6.3 homepage: https://github.com/cobit/krpc @@ -30,10 +30,12 @@ source-repository head library + default-language: Haskell2010 + default-extensions: PatternGuards + hs-source-dirs: src exposed-modules: Remote.KRPC , Remote.KRPC.Protocol , Remote.KRPC.Scheme - build-depends: base == 4.* , lifted-base >= 0.1.1 @@ -42,18 +44,16 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding >= 0.1 + , bencoding >= 0.2 , network >= 2.3 - - hs-source-dirs: src - extensions: PatternGuards ghc-options: -Wall - test-suite test-client type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests main-is: Client.hs other-modules: Shared build-depends: base == 4.* @@ -69,9 +69,10 @@ test-suite test-client , test-framework , test-framework-hunit - hs-source-dirs: tests executable test-server + default-language: Haskell2010 + hs-source-dirs: tests main-is: Server.hs other-modules: Shared build-depends: base == 4.* @@ -79,20 +80,22 @@ executable test-server , bencoding , krpc - hs-source-dirs: tests - - - - executable bench-server - main-is: Server.hs - build-depends: base == 4.*, krpc, bytestring + default-language: Haskell2010 hs-source-dirs: bench + main-is: Server.hs + build-depends: base == 4.* + , bytestring + , krpc ghc-options: -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 - main-is: Main.hs + default-language: Haskell2010 hs-source-dirs: bench - build-depends: base == 4.*, krpc, criterion, bytestring + main-is: Main.hs + build-depends: base == 4.* + , bytestring + , criterion + , krpc ghc-options: -O2 -fforce-recomp \ No newline at end of file -- cgit v1.2.3 From dd17435306b98d55854016e15af8cf51687dad22 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 01:15:33 +0400 Subject: + Added show instance for method. --- TODO.org | 3 ++- krpc.cabal | 1 + src/Remote/KRPC.hs | 49 ++++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 45 insertions(+), 8 deletions(-) diff --git a/TODO.org b/TODO.org index fc8ad395..ddd2a846 100644 --- a/TODO.org +++ b/TODO.org @@ -8,7 +8,8 @@ * DONE fix performance issues * DONE add readme * DONE return scheme back -* TODO add show instance for method +* DONE add Show instance for Method +* TODO add BEncodable instance for Method * TODO hide async api * TODO expose client addr in server-side * TODO major version bump (reason: exported type changed) diff --git a/krpc.cabal b/krpc.cabal index ab8d8f77..20553dee 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -32,6 +32,7 @@ source-repository head library default-language: Haskell2010 default-extensions: PatternGuards + , RecordWildCards hs-source-dirs: src exposed-modules: Remote.KRPC , Remote.KRPC.Protocol diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 485327e1..71faa3f3 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -84,12 +84,13 @@ -- -- For protocol details see 'Remote.KRPC.Protocol' module. -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} module Remote.KRPC ( -- * Method Method(..) @@ -116,6 +117,7 @@ import Data.BEncode import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M +import Data.Monoid import Data.Typeable import Network @@ -154,7 +156,40 @@ data Method param result = Method { , methodVals :: [ValName] } --- TODO ppMethod +instance (Typeable a, Typeable b) => Show (Method a b) where + showsPrec _ = showsMethod + +showsMethod + :: forall a. forall b. + Typeable a => Typeable b + => Method a b -> ShowS +showsMethod Method {..} = + showString (BC.unpack methodName) <> + showString " :: " <> + showsTuple methodParams paramsTy <> + showString " -> " <> + showsTuple methodVals valuesTy + where + paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) + valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) + + showsTuple ns ty + = showChar '(' + <> mconcat (L.intersperse (showString ", ") $ + L.zipWith showsTyArgName ns (detuple ty)) + <> showChar ')' + + showsTyArgName ns ty + = showString (BC.unpack ns) + <> showString " :: " + <> showString (show ty) + + detuple tyRep + | L.null args = [tyRep] + | otherwise = args + where + args = typeRepArgs tyRep + -- | Identity procedure signature. Could be used for echo -- servers. Implemented as: -- cgit v1.2.3 From 456ac8cd6d8d2f7d2f83bdd0f82752c89d59b0c4 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 01:19:27 +0400 Subject: + Added Generic instance for Method. --- TODO.org | 4 ++-- src/Remote/KRPC.hs | 8 +++++++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/TODO.org b/TODO.org index ddd2a846..7a8ac308 100644 --- a/TODO.org +++ b/TODO.org @@ -9,7 +9,7 @@ * DONE add readme * DONE return scheme back * DONE add Show instance for Method -* TODO add BEncodable instance for Method -* TODO hide async api +* DONE add BEncodable instance for Method +* TODO remove async api * TODO expose client addr in server-side * TODO major version bump (reason: exported type changed) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 71faa3f3..88882da2 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -91,6 +91,7 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} module Remote.KRPC ( -- * Method Method(..) @@ -121,8 +122,11 @@ import Data.Monoid import Data.Typeable import Network +import GHC.Generics + import Remote.KRPC.Protocol + -- | Method datatype used to describe name, parameters and return -- values of procedure. Client use a method to /invoke/, server -- /implements/ the method to make the actual work. @@ -154,7 +158,9 @@ data Method param result = Method { -- | Name of each return value in /right to left/ order. , methodVals :: [ValName] - } + } deriving (Eq, Ord, Generic) + +instance BEncodable (Method a b) instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod -- cgit v1.2.3 From 2c215c8f26f135e304fb653fc0b3fd0eab856e7f Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 01:39:37 +0400 Subject: - Remove async API. --- TODO.org | 4 ++-- src/Remote/KRPC.hs | 53 ++++++----------------------------------------------- 2 files changed, 8 insertions(+), 49 deletions(-) diff --git a/TODO.org b/TODO.org index 7a8ac308..fa2df33c 100644 --- a/TODO.org +++ b/TODO.org @@ -10,6 +10,6 @@ * DONE return scheme back * DONE add Show instance for Method * DONE add BEncodable instance for Method -* TODO remove async api -* TODO expose client addr in server-side +* DONE remove async api +* TODO expose client addr in server-side handlers * TODO major version bump (reason: exported type changed) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 88882da2..ab989782 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -80,6 +80,8 @@ -- Here we implement method signature from that shared lib and run -- server with runServer by passing method table in. -- +-- For async API use /async/ package, old API have been removed. +-- -- For more examples see @exsamples@ or @tests@ directories. -- -- For protocol details see 'Remote.KRPC.Protocol' module. @@ -100,10 +102,12 @@ module Remote.KRPC -- * Client , RemoteAddr , RPCException(..) - , call, Async, async, await + , call -- * Server - , MethodHandler, (==>), server + , MethodHandler + , (==>) + , server -- * Internal , call_ @@ -301,51 +305,6 @@ call_ sock addr m arg = liftIO $ do getResult sock m --- | Asynchonous result typically get from 'async' call. Used to defer --- return values transfer. -newtype Async result = Async { waitResult :: IO result } - - --- | Query procedure call but not wait for its results. This function --- returns 'Async' value which is handle to procedure result. Actual --- result might be obtained with 'await'. Unable to throw --- 'RPCException', this might happen in 'await' if at all. --- --- Note that sending multiple queries at the same time to the one --- remote is not recommended. For exsample in the following scenario: --- --- > aa <- async theRemote .... --- > ab <- async theRemote .... --- > a <- await ab --- > b <- await ab --- --- it's likely that the /a/ and /b/ values will be mixed up. So in --- order to get correct results you need to make 'await' before the --- next 'async'. --- -async :: MonadIO host - => (BEncodable param, BEncodable result) - => RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host (Async result) -- ^ Handle to result. -async addr m arg = do - liftIO $ withRemote $ \sock -> - queryCall sock addr m arg - return $ Async $ withRemote $ \sock -> - getResult sock m - --- | Will wait until the callee finished processing of procedure call --- and return its results. Throws 'RPCException' on any error --- occurred. -await :: MonadIO host - => Async result -- ^ Obtained from the corresponding 'async'. - -> host result -- ^ Result values of the procedure call quered - -- with 'async'. -await = liftIO . waitResult -{-# INLINE await #-} - - type HandlerBody remote = KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. -- cgit v1.2.3 From c30bd05cd274426ff299135984f2ef1c452d984e Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 01:53:58 +0400 Subject: + Expose caller address in handlers. --- TODO.org | 4 ++-- src/Remote/KRPC.hs | 28 +++++++++++++++++++--------- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/TODO.org b/TODO.org index fa2df33c..9bbf5683 100644 --- a/TODO.org +++ b/TODO.org @@ -11,5 +11,5 @@ * DONE add Show instance for Method * DONE add BEncodable instance for Method * DONE remove async api -* TODO expose client addr in server-side handlers -* TODO major version bump (reason: exported type changed) +* DONE expose client addr in server-side handlers +* TODO major version bump to 0.2.0.0 (reason: async API removed) diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index ab989782..be5673d8 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -107,6 +107,7 @@ module Remote.KRPC -- * Server , MethodHandler , (==>) + , (==>@) , server -- * Internal @@ -125,7 +126,6 @@ import Data.Map as M import Data.Monoid import Data.Typeable import Network - import GHC.Generics import Remote.KRPC.Protocol @@ -305,7 +305,7 @@ call_ sock addr m arg = liftIO $ do getResult sock m -type HandlerBody remote = KQuery -> remote (Either KError KResponse) +type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) @@ -319,17 +319,28 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -> (param -> remote result) -- ^ Implementation. -> MethodHandler remote -- ^ Handler used by server. {-# INLINE (==>) #-} -m ==> body = (methodName m, newbody) +m ==> body = m ==>@ const body +infix 1 ==> + +-- | Similar to '==>@' but additionally pass caller address. +(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncodable param, BEncodable result) + => Monad remote + => Method param result -- ^ Signature. + -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>@) #-} +m ==>@ body = (methodName m, newbody) where {-# INLINE newbody #-} - newbody q = + newbody addr q = case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do - r <- body a + r <- body addr a return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) -infix 1 ==> +infix 1 ==>@ -- TODO: allow forkIO @@ -342,11 +353,10 @@ server :: (MonadBaseControl IO remote, MonadIO remote) -> [MethodHandler remote] -- ^ Method table. -> remote () server servport handlers = do - remoteServer servport $ \_ q -> do + remoteServer servport $ \addr q -> do case dispatch (queryMethod q) of Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> invoke m q + Just m -> m addr q where handlerMap = M.fromList handlers dispatch s = M.lookup s handlerMap - invoke m q = m q -- cgit v1.2.3 From 6f8a2a89b2c728d98a41b34565b3484d450be9e7 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 02:11:35 +0400 Subject: ~ Bump version. --- krpc.cabal | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index 20553dee..450ca624 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.1.1.0 +version: 0.2.0.0 license: MIT license-file: LICENSE author: Sam T. @@ -22,6 +22,9 @@ description: * /0.1.0.0:/ Initial version. . * /0.1.1.0:/ Allow passing raw argument\/result dictionaries. + . + * /0.2.0.0:/ Async API have been removed, use /async/ package instead. + Expose caller address in handlers. source-repository head type: git -- cgit v1.2.3 From 6472927def976dbd9169bd89fcda229d11195a10 Mon Sep 17 00:00:00 2001 From: Sam T Date: Tue, 27 Aug 2013 02:16:01 +0400 Subject: ~ Update TODO list. --- TODO.org | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/TODO.org b/TODO.org index 9bbf5683..6303e445 100644 --- a/TODO.org +++ b/TODO.org @@ -12,4 +12,5 @@ * DONE add BEncodable instance for Method * DONE remove async api * DONE expose client addr in server-side handlers -* TODO major version bump to 0.2.0.0 (reason: async API removed) +* DONE major version bump to 0.2.0.0 (reason: async API removed) +* TODO ipv6 support -- cgit v1.2.3 From def28fcc62237dd2cd57917a76af99d847c7a8d1 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 03:53:49 +0400 Subject: Added `source-repository this` to cabal --- krpc.cabal | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index 450ca624..fd8400e5 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -29,8 +29,13 @@ description: source-repository head type: git location: git://github.com/cobit/krpc.git + branch: master - +source-repository this + type: git + location: git://github.com/cobit/krpc.git + branch: master + tag: v0.2.1.0 library default-language: Haskell2010 -- cgit v1.2.3 From e15ccfcdfb25edfc7b69f90a863b2f8803d55c0f Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 04:20:21 +0400 Subject: Update README --- README.md | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 18a7242e..ccbd6789 100644 --- a/README.md +++ b/README.md @@ -26,16 +26,14 @@ description. For usage see examples in ```examples``` directory. For documentation see haddock generated documentation. -### Build Status +### Build Status [![Build Status][status-img]][status-link] -[![Build Status][status-img]][status-link] +### Maintainer -### Maintainer - -This library is written and maintained by Sam T. - -Feel free to report bugs and suggestions via github issue tracker or the mail. +Feel free to report bugs and suggestions via github +[issue tracker][issues] or the mail. [spec]: http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol [status-img]: https://travis-ci.org/cobit/krpc.png [status-link]: https://travis-ci.org/cobit/krpc +[issues]: https://github.com/cobit/krpc/issues -- cgit v1.2.3 From 955888d11be6922cc5a11521f7938af345480bf4 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 04:20:57 +0400 Subject: Update TODO --- TODO.org | 1 + 1 file changed, 1 insertion(+) diff --git a/TODO.org b/TODO.org index 6303e445..e7f5c800 100644 --- a/TODO.org +++ b/TODO.org @@ -13,4 +13,5 @@ * DONE remove async api * DONE expose client addr in server-side handlers * DONE major version bump to 0.2.0.0 (reason: async API removed) +* TODO Remote.* -> Network.* * TODO ipv6 support -- cgit v1.2.3 From 6eb8e9e658484c018e3ca63678538de9d969893d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 04:22:42 +0400 Subject: Use BSD3 license --- LICENSE | 43 +++++++++++++++++++++++++++---------------- krpc.cabal | 8 ++++---- src/Remote/KRPC.hs | 4 ++-- src/Remote/KRPC/Protocol.hs | 8 +++----- src/Remote/KRPC/Scheme.hs | 4 ++-- 5 files changed, 38 insertions(+), 29 deletions(-) diff --git a/LICENSE b/LICENSE index dd0c3581..4c30139e 100644 --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,30 @@ -Copyright (c) 2013 Sam T. +Copyright (c) 2013, Sam Truzjan -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: +All rights reserved. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: -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. + * 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 Sam Truzjan 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. diff --git a/krpc.cabal b/krpc.cabal index fd8400e5..8db1c203 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,10 +1,10 @@ name: krpc version: 0.2.0.0 -license: MIT +license: BSD3 license-file: LICENSE -author: Sam T. -maintainer: Sam T. -copyright: (c) 2013, Sam T. +author: Sam Truzjan +maintainer: Sam Truzjan +copyright: (c) 2013, Sam Truzjan category: Network build-type: Simple cabal-version: >= 1.10 diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index be5673d8..3659ec66 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -1,6 +1,6 @@ -- | --- Copyright : (c) Sam T. 2013 --- License : MIT +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental -- Portability : portable diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index a569066f..06e54f78 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -1,6 +1,6 @@ -- | --- Copyright : (c) Sam T. 2013 --- License : MIT +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental -- Portability : portable @@ -18,9 +18,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-} module Remote.KRPC.Protocol - ( - - -- * Error + ( -- * Error KError(..), ErrorCode, errorCode, mkKError -- * Query diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs index 1cf970ea..ebdc7740 100644 --- a/src/Remote/KRPC/Scheme.hs +++ b/src/Remote/KRPC/Scheme.hs @@ -1,6 +1,6 @@ -- | --- Copyright : (c) Sam T. 2013 --- License : MIT +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental -- Portability : portable -- cgit v1.2.3 From 4d6660816a9d824f5b30cef47fe2ce96c67430fc Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 05:06:54 +0400 Subject: Update dependencies --- krpc.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 8db1c203..42ad8344 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -35,7 +35,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.2.1.0 + tag: v0.2.0.0 library default-language: Haskell2010 @@ -53,7 +53,7 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding >= 0.2 + , bencoding == 0.2.2.* , network >= 2.3 ghc-options: -Wall -- cgit v1.2.3 From 99e570b26a4a448d4dca5595eb4dbb3c718c3738 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 05:07:32 +0400 Subject: Bump version --- krpc.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 42ad8344..16d87796 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.2.0.0 +version: 0.2.2.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -35,7 +35,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.2.0.0 + tag: v0.2.2.0 library default-language: Haskell2010 -- cgit v1.2.3 From 8fdb03a12c119c22fc93e15036e37a267f158f1d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 06:58:05 +0400 Subject: Add .mailmap --- .mailmap | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 .mailmap diff --git a/.mailmap b/.mailmap new file mode 100644 index 00000000..8bd8f809 --- /dev/null +++ b/.mailmap @@ -0,0 +1,2 @@ +Sam Truzjan +Sam Truzjan \ No newline at end of file -- cgit v1.2.3 From 318d70b38cf1e994b4b2f01ee92a5fe272310913 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:31:44 +0400 Subject: Move release notes to separate file --- NEWS.md | 5 +++++ krpc.cabal | 9 +-------- 2 files changed, 6 insertions(+), 8 deletions(-) create mode 100644 NEWS.md diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 00000000..2c8f2d71 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,5 @@ +* 0.1.0.0: Initial version. +* 0.1.1.0: Allow passing raw argument\/result dictionaries. +* 0.2.0.0: Async API have been removed, use /async/ package instead. + Expose caller address in handlers. +* 0.2.2.0: Use bencoding-0.2.2.* diff --git a/krpc.cabal b/krpc.cabal index 16d87796..d32e8247 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -17,14 +17,7 @@ description: KRPC remote procedure call protocol implementation. . - [/Release Notes/] - . - * /0.1.0.0:/ Initial version. - . - * /0.1.1.0:/ Allow passing raw argument\/result dictionaries. - . - * /0.2.0.0:/ Async API have been removed, use /async/ package instead. - Expose caller address in handlers. + See NEWS.md for release notes. source-repository head type: git -- cgit v1.2.3 From e8689169dd60392981436d85a1dd81168846c8f5 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:32:13 +0400 Subject: Add missing files to cabal --- krpc.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/krpc.cabal b/krpc.cabal index d32e8247..f382244c 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -19,6 +19,9 @@ description: . See NEWS.md for release notes. +extra-source-files: README.md + , NEWS.md + source-repository head type: git location: git://github.com/cobit/krpc.git -- cgit v1.2.3 From a2a6f703d679340e5abcdd12e5f88f8afd3204d6 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:38:03 +0400 Subject: Use newer bencodable package --- krpc.cabal | 2 +- src/Remote/KRPC.hs | 22 +++++++++++----------- src/Remote/KRPC/Protocol.hs | 24 +++++++++++------------- tests/Shared.hs | 4 ++-- 4 files changed, 25 insertions(+), 27 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index f382244c..0ac9faac 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -49,7 +49,7 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding == 0.2.2.* + , bencoding == 0.3.* , network >= 2.3 ghc-options: -Wall diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs index 3659ec66..5c913daa 100644 --- a/src/Remote/KRPC.hs +++ b/src/Remote/KRPC.hs @@ -164,7 +164,7 @@ data Method param result = Method { , methodVals :: [ValName] } deriving (Eq, Ord, Generic) -instance BEncodable (Method a b) +instance BEncode (Method a b) instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod @@ -224,16 +224,16 @@ method :: MethodName -> [ParamName] -> [ValName] -> Method param result method = Method {-# INLINE method #-} -lookupKey :: ParamName -> Map ByteString BEncode -> Result BEncode +lookupKey :: ParamName -> BDict -> Result BValue lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x -extractArgs :: [ParamName] -> Map ParamName BEncode -> Result BEncode +extractArgs :: [ParamName] -> BDict -> Result BValue extractArgs [] d = Right $ if M.null d then BList [] else BDict d extractArgs [x] d = lookupKey x d extractArgs xs d = BList <$> mapM (`lookupKey` d) xs {-# INLINE extractArgs #-} -injectVals :: [ParamName] -> BEncode -> [(ParamName, BEncode)] +injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] injectVals [] (BList []) = [] injectVals [] (BDict d ) = M.toList d injectVals [] be = invalidParamList [] be @@ -242,7 +242,7 @@ injectVals ps (BList as) = L.zip ps as injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} -invalidParamList :: [ParamName] -> BEncode -> a +invalidParamList :: [ParamName] -> BValue -> a invalidParamList pl be = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ "while procedure args are: " ++ show be @@ -262,14 +262,14 @@ instance Exception RPCException -- | Address of remote can be called by client. type RemoteAddr = KRemoteAddr -queryCall :: BEncodable param +queryCall :: BEncode param => KRemote -> KRemoteAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) -getResult :: BEncodable result +getResult :: BEncode result => KRemote -> Method param result -> IO result getResult sock m = do @@ -285,7 +285,7 @@ getResult sock m = do -- | Makes remote procedure call. Throws RPCException on any error -- occurred. call :: (MonadBaseControl IO host, MonadIO host) - => (BEncodable param, BEncodable result) + => (BEncode param, BEncode result) => RemoteAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. @@ -294,7 +294,7 @@ call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg -- | The same as 'call' but use already opened socket. call_ :: (MonadBaseControl IO host, MonadIO host) - => (BEncodable param, BEncodable result) + => (BEncode param, BEncode result) => Remote -- ^ Socket to use -> RemoteAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. @@ -313,7 +313,7 @@ type MethodHandler remote = (MethodName, HandlerBody remote) -- we can safely erase types in (==>) -- | Assign method implementation to the method signature. (==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) + (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. -> (param -> remote result) -- ^ Implementation. @@ -324,7 +324,7 @@ infix 1 ==> -- | Similar to '==>@' but additionally pass caller address. (==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncodable param, BEncodable result) + (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs index 06e54f78..d28fdbeb 100644 --- a/src/Remote/KRPC/Protocol.hs +++ b/src/Remote/KRPC/Protocol.hs @@ -74,8 +74,8 @@ data KError | MethodUnknown { errorMessage :: ByteString } deriving (Show, Read, Eq, Ord) -instance BEncodable KError where - {-# SPECIALIZE instance BEncodable KError #-} +instance BEncode KError where + {-# SPECIALIZE instance BEncode KError #-} {-# INLINE toBEncode #-} toBEncode e = fromAscAssocs -- WARN: keep keys sorted [ "e" --> (errorCode e, errorMessage e) @@ -125,11 +125,11 @@ type ParamName = ByteString -- data KQuery = KQuery { queryMethod :: MethodName - , queryArgs :: Map ParamName BEncode + , queryArgs :: Map ParamName BValue } deriving (Show, Read, Eq, Ord) -instance BEncodable KQuery where - {-# SPECIALIZE instance BEncodable KQuery #-} +instance BEncode KQuery where + {-# SPECIALIZE instance BEncode KQuery #-} {-# INLINE toBEncode #-} toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted [ "a" --> BDict args @@ -145,7 +145,7 @@ instance BEncodable KQuery where fromBEncode _ = decodingError "KQuery" -kquery :: MethodName -> [(ParamName, BEncode)] -> KQuery +kquery :: MethodName -> [(ParamName, BValue)] -> KQuery kquery name args = KQuery name (M.fromList args) {-# INLINE kquery #-} @@ -163,12 +163,10 @@ type ValName = ByteString -- -- > { "y" : "r", "r" : [, , ...] } -- -newtype KResponse = KResponse { - respVals :: Map ValName BEncode - } deriving (Show, Read, Eq, Ord) +newtype KResponse = KResponse { respVals :: BDict } + deriving (Show, Read, Eq, Ord) -instance BEncodable KResponse where - {-# SPECIALIZE instance BEncodable KResponse #-} +instance BEncode KResponse where {-# INLINE toBEncode #-} toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted [ "r" --> vals @@ -183,7 +181,7 @@ instance BEncodable KResponse where fromBEncode _ = decodingError "KDict" -kresponse :: [(ValName, BEncode)] -> KResponse +kresponse :: [(ValName, BValue)] -> KResponse kresponse = KResponse . M.fromList {-# INLINE kresponse #-} @@ -208,7 +206,7 @@ maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict -sendMessage :: BEncodable msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () sendMessage msg (host, port) sock = sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) {-# INLINE sendMessage #-} diff --git a/tests/Shared.hs b/tests/Shared.hs index f64112da..1060cfc8 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -32,8 +32,8 @@ swapM = method "swap" ["x", "y"] ["b", "a"] shiftR :: Method ((), Int, [Int]) ([Int], (), Int) shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] -rawM :: Method BEncode BEncode +rawM :: Method BValue BValue rawM = method "rawM" [""] [""] -rawDictM :: Method BEncode BEncode +rawDictM :: Method BValue BValue rawDictM = method "m" [] [] \ No newline at end of file -- cgit v1.2.3 From 60236767ea511a95056ae3b3df5f298d443480de Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:39:38 +0400 Subject: [Travis]: Install bencodable from Hackage --- .travis.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8cb74db1..bd6d7366 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,8 +4,6 @@ notifications: email: false install: - - git clone https://github.com/cobit/bencoding.git - - cd bencoding && cabal install --force-reinstalls && cd .. - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls script: -- cgit v1.2.3 From a06f12d84d5c09e41078cf1e819bf175ec41b524 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:41:32 +0400 Subject: Rename Remote to Network --- src/Network/KRPC.hs | 362 +++++++++++++++++++++++++++++++++++++++++++ src/Network/KRPC/Protocol.hs | 249 +++++++++++++++++++++++++++++ src/Network/KRPC/Scheme.hs | 80 ++++++++++ src/Remote/KRPC.hs | 362 ------------------------------------------- src/Remote/KRPC/Protocol.hs | 249 ----------------------------- src/Remote/KRPC/Scheme.hs | 80 ---------- 6 files changed, 691 insertions(+), 691 deletions(-) create mode 100644 src/Network/KRPC.hs create mode 100644 src/Network/KRPC/Protocol.hs create mode 100644 src/Network/KRPC/Scheme.hs delete mode 100644 src/Remote/KRPC.hs delete mode 100644 src/Remote/KRPC/Protocol.hs delete mode 100644 src/Remote/KRPC/Scheme.hs diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs new file mode 100644 index 00000000..5c913daa --- /dev/null +++ b/src/Network/KRPC.hs @@ -0,0 +1,362 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides safe remote procedure call. One important +-- point is exceptions and errors, so be able handle them properly +-- we need to investigate a bit about how this all works. +-- Internally, in order to make method invokation KRPC makes the +-- following steps: +-- +-- * Caller serialize arguments to bencoded bytestrings; +-- +-- * Caller send bytestring data over UDP to the callee; +-- +-- * Callee receive and decode arguments to the method and method +-- name. If it can't decode then it send 'ProtocolError' back to the +-- caller; +-- +-- * Callee search for the @method name@ in the method table. +-- If it not present in the table then callee send 'MethodUnknown' +-- back to the caller; +-- +-- * Callee check if argument names match. If not it send +-- 'ProtocolError' back; +-- +-- * Callee make the actuall call to the plain old haskell +-- function. If the function throw exception then callee send +-- 'ServerError' back. +-- +-- * Callee serialize result of the function to bencoded bytestring. +-- +-- * Callee encode result to bencoded bytestring and send it back +-- to the caller. +-- +-- * Caller check if return values names match with the signature +-- it called in the first step. +-- +-- * Caller extracts results and finally return results of the +-- procedure call as ordinary haskell values. +-- +-- If every other error occurred caller get the 'GenericError'. All +-- errors returned by callee are throwed as ordinary haskell +-- exceptions at caller side. Make sure that both callee and caller +-- uses the same method signatures and everything should be ok: this +-- KRPC implementation provides some level of safety through +-- types. Also note that both caller and callee use plain UDP, so +-- KRPC is unreliable. +-- +-- Consider one tiny example. From now @caller = client@ and +-- @callee = server or remote@. +-- +-- Somewhere we have to define all procedure signatures. Imagine +-- that this is a library shared between client and server: +-- +-- > factorialMethod :: Method Int Int +-- > factorialMethod = method "factorial" ["x"] ["y"] +-- +-- Otherwise you can define this code in both client and server of +-- course. But in this case you might get into troubles: you can get +-- 'MethodUnknown' or 'ProtocolError' if name or type of method +-- will mismatch after not synced changes in client or server code. +-- +-- Now let's define our client-side: +-- +-- > main = withRemote $ \remote -> do +-- > result <- call remote (0, 6000) factorialMethod 4 +-- > assert (result == 24) $ print "Success!" +-- +-- It basically open socket with 'withRemote' and make all the other +-- steps in 'call' as describe above. And finally our server-side: +-- +-- > factorialImpl :: Int -> Int +-- > factorialImpl n = product [1..n] +-- > +-- > main = runServer [factorialMethod $ return . factorialImpl] +-- +-- Here we implement method signature from that shared lib and run +-- server with runServer by passing method table in. +-- +-- For async API use /async/ package, old API have been removed. +-- +-- For more examples see @exsamples@ or @tests@ directories. +-- +-- For protocol details see 'Remote.KRPC.Protocol' module. +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +module Remote.KRPC + ( -- * Method + Method(..) + , method, idM + + -- * Client + , RemoteAddr + , RPCException(..) + , call + + -- * Server + , MethodHandler + , (==>) + , (==>@) + , server + + -- * Internal + , call_ + , withRemote + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad.Trans.Control +import Control.Monad.IO.Class +import Data.BEncode +import Data.ByteString.Char8 as BC +import Data.List as L +import Data.Map as M +import Data.Monoid +import Data.Typeable +import Network +import GHC.Generics + +import Remote.KRPC.Protocol + + +-- | Method datatype used to describe name, parameters and return +-- values of procedure. Client use a method to /invoke/, server +-- /implements/ the method to make the actual work. +-- +-- We use the following fantom types to ensure type-safiety: +-- +-- * param: Type of method parameters. Ordinary Tuple type used +-- to specify more than one parameter, so for example @Method +-- (Int, Int) result@ will take two arguments. +-- +-- * result: Type of return value of the method. Similarly, +-- tuple used to specify more than one return value, so for +-- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments +-- and return two values. +-- +-- To pass raw dictionaries you should specify empty param list: +-- +-- > method "my_method" [] [] :: Method BEncode BEncode +-- +-- In this case you should handle dictionary extraction by hand, both +-- in client and server. +-- +data Method param result = Method { + -- | Name used in query. + methodName :: MethodName + + -- | Name of each parameter in /right to left/ order. + , methodParams :: [ParamName] + + -- | Name of each return value in /right to left/ order. + , methodVals :: [ValName] + } deriving (Eq, Ord, Generic) + +instance BEncode (Method a b) + +instance (Typeable a, Typeable b) => Show (Method a b) where + showsPrec _ = showsMethod + +showsMethod + :: forall a. forall b. + Typeable a => Typeable b + => Method a b -> ShowS +showsMethod Method {..} = + showString (BC.unpack methodName) <> + showString " :: " <> + showsTuple methodParams paramsTy <> + showString " -> " <> + showsTuple methodVals valuesTy + where + paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) + valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) + + showsTuple ns ty + = showChar '(' + <> mconcat (L.intersperse (showString ", ") $ + L.zipWith showsTyArgName ns (detuple ty)) + <> showChar ')' + + showsTyArgName ns ty + = showString (BC.unpack ns) + <> showString " :: " + <> showString (show ty) + + detuple tyRep + | L.null args = [tyRep] + | otherwise = args + where + args = typeRepArgs tyRep + + +-- | Identity procedure signature. Could be used for echo +-- servers. Implemented as: +-- +-- > idM = method "id" ["x"] ["y"] +-- +idM :: Method a a +idM = method "id" ["x"] ["y"] +{-# INLINE idM #-} + +-- | Makes method signature. Note that order of parameters and return +-- values are not important as long as corresponding names and types +-- are match. For exsample this is the equal definitions: +-- +-- > methodA : Method (Foo, Bar) (Baz, Quux) +-- > methodA = method "mymethod" ["a", "b"] ["c", "d"] +-- +-- > methodA : Method (Bar, Foo) (Quux, Baz) +-- > methodB = method "mymethod" ["b", "a"] ["d", "c"] +-- +method :: MethodName -> [ParamName] -> [ValName] -> Method param result +method = Method +{-# INLINE method #-} + +lookupKey :: ParamName -> BDict -> Result BValue +lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x + +extractArgs :: [ParamName] -> BDict -> Result BValue +extractArgs [] d = Right $ if M.null d then BList [] else BDict d +extractArgs [x] d = lookupKey x d +extractArgs xs d = BList <$> mapM (`lookupKey` d) xs +{-# INLINE extractArgs #-} + +injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] +injectVals [] (BList []) = [] +injectVals [] (BDict d ) = M.toList d +injectVals [] be = invalidParamList [] be +injectVals [p] arg = [(p, arg)] +injectVals ps (BList as) = L.zip ps as +injectVals ps be = invalidParamList ps be +{-# INLINE injectVals #-} + +invalidParamList :: [ParamName] -> BValue -> a +invalidParamList pl be + = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ + "while procedure args are: " ++ show be + +-- | Alias to Socket, through might change in future. +type Remote = Socket + +-- | Represent any error mentioned by protocol specification that +-- 'call', 'await' might throw. +-- For more details see 'Remote.KRPC.Protocol'. +-- +data RPCException = RPCException KError + deriving (Show, Eq, Typeable) + +instance Exception RPCException + +-- | Address of remote can be called by client. +type RemoteAddr = KRemoteAddr + +queryCall :: BEncode param + => KRemote -> KRemoteAddr + -> Method param result -> param -> IO () +queryCall sock addr m arg = sendMessage q addr sock + where + q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) + +getResult :: BEncode result + => KRemote + -> Method param result -> IO result +getResult sock m = do + resp <- recvResponse sock + case resp of + Left e -> throw (RPCException e) + Right (respVals -> dict) -> do + case fromBEncode =<< extractArgs (methodVals m) dict of + Right vals -> return vals + Left e -> throw (RPCException (ProtocolError (BC.pack e))) + + +-- | Makes remote procedure call. Throws RPCException on any error +-- occurred. +call :: (MonadBaseControl IO host, MonadIO host) + => (BEncode param, BEncode result) + => RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg + +-- | The same as 'call' but use already opened socket. +call_ :: (MonadBaseControl IO host, MonadIO host) + => (BEncode param, BEncode result) + => Remote -- ^ Socket to use + -> RemoteAddr -- ^ Address of callee. + -> Method param result -- ^ Procedure to call. + -> param -- ^ Arguments passed by callee to procedure. + -> host result -- ^ Values returned by callee from the procedure. +call_ sock addr m arg = liftIO $ do + queryCall sock addr m arg + getResult sock m + + +type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) + +-- | Procedure signature and implementation binded up. +type MethodHandler remote = (MethodName, HandlerBody remote) + +-- we can safely erase types in (==>) +-- | Assign method implementation to the method signature. +(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncode param, BEncode result) + => Monad remote + => Method param result -- ^ Signature. + -> (param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>) #-} +m ==> body = m ==>@ const body +infix 1 ==> + +-- | Similar to '==>@' but additionally pass caller address. +(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). + (BEncode param, BEncode result) + => Monad remote + => Method param result -- ^ Signature. + -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> MethodHandler remote -- ^ Handler used by server. +{-# INLINE (==>@) #-} +m ==>@ body = (methodName m, newbody) + where + {-# INLINE newbody #-} + newbody addr q = + case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of + Left e -> return (Left (ProtocolError (BC.pack e))) + Right a -> do + r <- body addr a + return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) + +infix 1 ==>@ + +-- TODO: allow forkIO + +-- | Run RPC server on specified port by using list of handlers. +-- Server will dispatch procedure specified by callee, but note that +-- it will not create new thread for each connection. +-- +server :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber -- ^ Port used to accept incoming connections. + -> [MethodHandler remote] -- ^ Method table. + -> remote () +server servport handlers = do + remoteServer servport $ \addr q -> do + case dispatch (queryMethod q) of + Nothing -> return $ Left $ MethodUnknown (queryMethod q) + Just m -> m addr q + where + handlerMap = M.fromList handlers + dispatch s = M.lookup s handlerMap diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs new file mode 100644 index 00000000..d28fdbeb --- /dev/null +++ b/src/Network/KRPC/Protocol.hs @@ -0,0 +1,249 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides straightforward implementation of KRPC +-- protocol. In many situations 'Network.KRPC' should be prefered +-- since it gives more safe, convenient and high level api. +-- +-- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +module Remote.KRPC.Protocol + ( -- * Error + KError(..), ErrorCode, errorCode, mkKError + + -- * Query + , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery + + -- * Response + , KResponse(respVals), ValName, kresponse + + , sendMessage, recvResponse + + -- * Remote + , KRemote, KRemoteAddr, withRemote, remoteServer + + -- * Re-exports + , encode, encoded, decode, decoded, toBEncode, fromBEncode + ) where + +import Control.Applicative +import Control.Exception.Lifted as Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Control + +import Data.BEncode +import Data.ByteString as B +import Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as LB +import Data.Map as M + +import Network.Socket hiding (recvFrom) +import Network.Socket.ByteString + + +-- | Errors used to signal that some error occurred while processing a +-- procedure call. Error may be send only from server to client but +-- not in the opposite direction. +-- +-- Errors are encoded as bencoded dictionary: +-- +-- > { "y" : "e", "e" : [, ] } +-- +data KError + -- | Some error doesn't fit in any other category. + = GenericError { errorMessage :: ByteString } + + -- | Occur when server fail to process procedure call. + | ServerError { errorMessage :: ByteString } + + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError { errorMessage :: ByteString } + + -- | Occur when client trying to call method server don't know. + | MethodUnknown { errorMessage :: ByteString } + deriving (Show, Read, Eq, Ord) + +instance BEncode KError where + {-# SPECIALIZE instance BEncode KError #-} + {-# INLINE toBEncode #-} + toBEncode e = fromAscAssocs -- WARN: keep keys sorted + [ "e" --> (errorCode e, errorMessage e) + , "y" --> ("e" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "e") + = uncurry mkKError <$> d >-- "e" + + fromBEncode _ = decodingError "KError" + +type ErrorCode = Int + +errorCode :: KError -> ErrorCode +errorCode (GenericError _) = 201 +errorCode (ServerError _) = 202 +errorCode (ProtocolError _) = 203 +errorCode (MethodUnknown _) = 204 +{-# INLINE errorCode #-} + +mkKError :: ErrorCode -> ByteString -> KError +mkKError 201 = GenericError +mkKError 202 = ServerError +mkKError 203 = ProtocolError +mkKError 204 = MethodUnknown +mkKError _ = GenericError +{-# INLINE mkKError #-} + +serverError :: SomeException -> KError +serverError = ServerError . BC.pack . show + +-- TODO Asc everywhere + + +type MethodName = ByteString +type ParamName = ByteString + +-- | Query used to signal that caller want to make procedure call to +-- callee and pass arguments in. Therefore query may be only sent from +-- client to server but not in the opposite direction. +-- +-- Queries are encoded as bencoded dictionary: +-- +-- > { "y" : "q", "q" : "", "a" : [, , ...] } +-- +data KQuery = KQuery { + queryMethod :: MethodName + , queryArgs :: Map ParamName BValue + } deriving (Show, Read, Eq, Ord) + +instance BEncode KQuery where + {-# SPECIALIZE instance BEncode KQuery #-} + {-# INLINE toBEncode #-} + toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted + [ "a" --> BDict args + , "q" --> m + , "y" --> ("q" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "q") = + KQuery <$> d >-- "q" + <*> d >-- "a" + + fromBEncode _ = decodingError "KQuery" + +kquery :: MethodName -> [(ParamName, BValue)] -> KQuery +kquery name args = KQuery name (M.fromList args) +{-# INLINE kquery #-} + + + + +type ValName = ByteString + +-- | KResponse used to signal that callee successufully process a +-- procedure call and to return values from procedure. KResponse should +-- not be sent if error occurred during RPC. Thus KResponse may be only +-- sent from server to client. +-- +-- Responses are encoded as bencoded dictionary: +-- +-- > { "y" : "r", "r" : [, , ...] } +-- +newtype KResponse = KResponse { respVals :: BDict } + deriving (Show, Read, Eq, Ord) + +instance BEncode KResponse where + {-# INLINE toBEncode #-} + toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted + [ "r" --> vals + , "y" --> ("r" :: ByteString) + ] + + {-# INLINE fromBEncode #-} + fromBEncode (BDict d) + | M.lookup "y" d == Just (BString "r") = + KResponse <$> d >-- "r" + + fromBEncode _ = decodingError "KDict" + + +kresponse :: [(ValName, BValue)] -> KResponse +kresponse = KResponse . M.fromList +{-# INLINE kresponse #-} + + + +type KRemoteAddr = (HostAddress, PortNumber) + +type KRemote = Socket + +withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a +withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) + (liftIO . sClose) +{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} + + +maxMsgSize :: Int +{-# INLINE maxMsgSize #-} +-- release +--maxMsgSize = 512 -- size of payload of one udp packet +-- bench +maxMsgSize = 64 * 1024 -- max udp size + + +-- TODO eliminate toStrict +sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage msg (host, port) sock = + sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) +{-# INLINE sendMessage #-} + +recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse sock = do + (raw, _) <- recvFrom sock maxMsgSize + return $ case decoded raw of + Right resp -> Right resp + Left decE -> Left $ case decoded raw of + Right kerror -> kerror + _ -> ProtocolError (BC.pack decE) + +-- | Run server using a given port. Method invocation should be done manually. +remoteServer :: (MonadBaseControl IO remote, MonadIO remote) + => PortNumber -- ^ Port number to listen. + -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) + -- ^ Handler. + -> remote () +remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop + where + bindServ = do + sock <- socket AF_INET Datagram defaultProtocol + bindSocket sock (SockAddrInet servport iNADDR_ANY) + return sock + + loop sock = forever $ do + (bs, addr) <- liftIO $ recvFrom sock maxMsgSize + case addr of + SockAddrInet port host -> do + let kaddr = (host, port) + reply <- handleMsg bs kaddr + liftIO $ sendMessage reply kaddr sock + _ -> return () + + where + handleMsg bs addr = case decoded bs of + Right query -> (either toBEncode toBEncode <$> action addr query) + `Lifted.catch` (return . toBEncode . serverError) + Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs new file mode 100644 index 00000000..ebdc7740 --- /dev/null +++ b/src/Network/KRPC/Scheme.hs @@ -0,0 +1,80 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides message scheme validation for core protocol +-- messages from 'Remote.KRPC.Procotol'. This module should be used +-- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') +-- this module seems to be useless. +-- +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +module Remote.KRPC.Scheme + ( KMessage(..) + , KQueryScheme(..), methodQueryScheme + , KResponseScheme(..), methodRespScheme + ) where + +import Control.Applicative +import Data.Map as M +import Data.Set as S + +import Remote.KRPC.Protocol +import Remote.KRPC + + +-- | Used to validate any message by its scheme +-- +-- forall m. m `validate` scheme m +-- +class KMessage message scheme | message -> scheme where + -- | Get a message scheme. + scheme :: message -> scheme + + -- | Check a message with a scheme. + validate :: message -> scheme -> Bool + + default validate :: Eq scheme => message -> scheme -> Bool + validate = (==) . scheme + {-# INLINE validate #-} + + +instance KMessage KError ErrorCode where + {-# SPECIALIZE instance KMessage KError ErrorCode #-} + scheme = errorCode + {-# INLINE scheme #-} + + +data KQueryScheme = KQueryScheme { + qscMethod :: MethodName + , qscParams :: Set ParamName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KQuery KQueryScheme where + {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} + scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) + {-# INLINE scheme #-} + +methodQueryScheme :: Method a b -> KQueryScheme +methodQueryScheme = KQueryScheme <$> methodName + <*> S.fromList . methodParams +{-# INLINE methodQueryScheme #-} + + +newtype KResponseScheme = KResponseScheme { + rscVals :: Set ValName + } deriving (Show, Read, Eq, Ord) + +instance KMessage KResponse KResponseScheme where + {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} + scheme = KResponseScheme . keysSet . respVals + {-# INLINE scheme #-} + +methodRespScheme :: Method a b -> KResponseScheme +methodRespScheme = KResponseScheme . S.fromList . methodVals +{-# INLINE methodRespScheme #-} diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs deleted file mode 100644 index 5c913daa..00000000 --- a/src/Remote/KRPC.hs +++ /dev/null @@ -1,362 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides safe remote procedure call. One important --- point is exceptions and errors, so be able handle them properly --- we need to investigate a bit about how this all works. --- Internally, in order to make method invokation KRPC makes the --- following steps: --- --- * Caller serialize arguments to bencoded bytestrings; --- --- * Caller send bytestring data over UDP to the callee; --- --- * Callee receive and decode arguments to the method and method --- name. If it can't decode then it send 'ProtocolError' back to the --- caller; --- --- * Callee search for the @method name@ in the method table. --- If it not present in the table then callee send 'MethodUnknown' --- back to the caller; --- --- * Callee check if argument names match. If not it send --- 'ProtocolError' back; --- --- * Callee make the actuall call to the plain old haskell --- function. If the function throw exception then callee send --- 'ServerError' back. --- --- * Callee serialize result of the function to bencoded bytestring. --- --- * Callee encode result to bencoded bytestring and send it back --- to the caller. --- --- * Caller check if return values names match with the signature --- it called in the first step. --- --- * Caller extracts results and finally return results of the --- procedure call as ordinary haskell values. --- --- If every other error occurred caller get the 'GenericError'. All --- errors returned by callee are throwed as ordinary haskell --- exceptions at caller side. Make sure that both callee and caller --- uses the same method signatures and everything should be ok: this --- KRPC implementation provides some level of safety through --- types. Also note that both caller and callee use plain UDP, so --- KRPC is unreliable. --- --- Consider one tiny example. From now @caller = client@ and --- @callee = server or remote@. --- --- Somewhere we have to define all procedure signatures. Imagine --- that this is a library shared between client and server: --- --- > factorialMethod :: Method Int Int --- > factorialMethod = method "factorial" ["x"] ["y"] --- --- Otherwise you can define this code in both client and server of --- course. But in this case you might get into troubles: you can get --- 'MethodUnknown' or 'ProtocolError' if name or type of method --- will mismatch after not synced changes in client or server code. --- --- Now let's define our client-side: --- --- > main = withRemote $ \remote -> do --- > result <- call remote (0, 6000) factorialMethod 4 --- > assert (result == 24) $ print "Success!" --- --- It basically open socket with 'withRemote' and make all the other --- steps in 'call' as describe above. And finally our server-side: --- --- > factorialImpl :: Int -> Int --- > factorialImpl n = product [1..n] --- > --- > main = runServer [factorialMethod $ return . factorialImpl] --- --- Here we implement method signature from that shared lib and run --- server with runServer by passing method table in. --- --- For async API use /async/ package, old API have been removed. --- --- For more examples see @exsamples@ or @tests@ directories. --- --- For protocol details see 'Remote.KRPC.Protocol' module. --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -module Remote.KRPC - ( -- * Method - Method(..) - , method, idM - - -- * Client - , RemoteAddr - , RPCException(..) - , call - - -- * Server - , MethodHandler - , (==>) - , (==>@) - , server - - -- * Internal - , call_ - , withRemote - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad.Trans.Control -import Control.Monad.IO.Class -import Data.BEncode -import Data.ByteString.Char8 as BC -import Data.List as L -import Data.Map as M -import Data.Monoid -import Data.Typeable -import Network -import GHC.Generics - -import Remote.KRPC.Protocol - - --- | Method datatype used to describe name, parameters and return --- values of procedure. Client use a method to /invoke/, server --- /implements/ the method to make the actual work. --- --- We use the following fantom types to ensure type-safiety: --- --- * param: Type of method parameters. Ordinary Tuple type used --- to specify more than one parameter, so for example @Method --- (Int, Int) result@ will take two arguments. --- --- * result: Type of return value of the method. Similarly, --- tuple used to specify more than one return value, so for --- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments --- and return two values. --- --- To pass raw dictionaries you should specify empty param list: --- --- > method "my_method" [] [] :: Method BEncode BEncode --- --- In this case you should handle dictionary extraction by hand, both --- in client and server. --- -data Method param result = Method { - -- | Name used in query. - methodName :: MethodName - - -- | Name of each parameter in /right to left/ order. - , methodParams :: [ParamName] - - -- | Name of each return value in /right to left/ order. - , methodVals :: [ValName] - } deriving (Eq, Ord, Generic) - -instance BEncode (Method a b) - -instance (Typeable a, Typeable b) => Show (Method a b) where - showsPrec _ = showsMethod - -showsMethod - :: forall a. forall b. - Typeable a => Typeable b - => Method a b -> ShowS -showsMethod Method {..} = - showString (BC.unpack methodName) <> - showString " :: " <> - showsTuple methodParams paramsTy <> - showString " -> " <> - showsTuple methodVals valuesTy - where - paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) - valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) - - showsTuple ns ty - = showChar '(' - <> mconcat (L.intersperse (showString ", ") $ - L.zipWith showsTyArgName ns (detuple ty)) - <> showChar ')' - - showsTyArgName ns ty - = showString (BC.unpack ns) - <> showString " :: " - <> showString (show ty) - - detuple tyRep - | L.null args = [tyRep] - | otherwise = args - where - args = typeRepArgs tyRep - - --- | Identity procedure signature. Could be used for echo --- servers. Implemented as: --- --- > idM = method "id" ["x"] ["y"] --- -idM :: Method a a -idM = method "id" ["x"] ["y"] -{-# INLINE idM #-} - --- | Makes method signature. Note that order of parameters and return --- values are not important as long as corresponding names and types --- are match. For exsample this is the equal definitions: --- --- > methodA : Method (Foo, Bar) (Baz, Quux) --- > methodA = method "mymethod" ["a", "b"] ["c", "d"] --- --- > methodA : Method (Bar, Foo) (Quux, Baz) --- > methodB = method "mymethod" ["b", "a"] ["d", "c"] --- -method :: MethodName -> [ParamName] -> [ValName] -> Method param result -method = Method -{-# INLINE method #-} - -lookupKey :: ParamName -> BDict -> Result BValue -lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x - -extractArgs :: [ParamName] -> BDict -> Result BValue -extractArgs [] d = Right $ if M.null d then BList [] else BDict d -extractArgs [x] d = lookupKey x d -extractArgs xs d = BList <$> mapM (`lookupKey` d) xs -{-# INLINE extractArgs #-} - -injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] -injectVals [] (BList []) = [] -injectVals [] (BDict d ) = M.toList d -injectVals [] be = invalidParamList [] be -injectVals [p] arg = [(p, arg)] -injectVals ps (BList as) = L.zip ps as -injectVals ps be = invalidParamList ps be -{-# INLINE injectVals #-} - -invalidParamList :: [ParamName] -> BValue -> a -invalidParamList pl be - = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ - "while procedure args are: " ++ show be - --- | Alias to Socket, through might change in future. -type Remote = Socket - --- | Represent any error mentioned by protocol specification that --- 'call', 'await' might throw. --- For more details see 'Remote.KRPC.Protocol'. --- -data RPCException = RPCException KError - deriving (Show, Eq, Typeable) - -instance Exception RPCException - --- | Address of remote can be called by client. -type RemoteAddr = KRemoteAddr - -queryCall :: BEncode param - => KRemote -> KRemoteAddr - -> Method param result -> param -> IO () -queryCall sock addr m arg = sendMessage q addr sock - where - q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) - -getResult :: BEncode result - => KRemote - -> Method param result -> IO result -getResult sock m = do - resp <- recvResponse sock - case resp of - Left e -> throw (RPCException e) - Right (respVals -> dict) -> do - case fromBEncode =<< extractArgs (methodVals m) dict of - Right vals -> return vals - Left e -> throw (RPCException (ProtocolError (BC.pack e))) - - --- | Makes remote procedure call. Throws RPCException on any error --- occurred. -call :: (MonadBaseControl IO host, MonadIO host) - => (BEncode param, BEncode result) - => RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg - --- | The same as 'call' but use already opened socket. -call_ :: (MonadBaseControl IO host, MonadIO host) - => (BEncode param, BEncode result) - => Remote -- ^ Socket to use - -> RemoteAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call_ sock addr m arg = liftIO $ do - queryCall sock addr m arg - getResult sock m - - -type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) - --- | Procedure signature and implementation binded up. -type MethodHandler remote = (MethodName, HandlerBody remote) - --- we can safely erase types in (==>) --- | Assign method implementation to the method signature. -(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncode param, BEncode result) - => Monad remote - => Method param result -- ^ Signature. - -> (param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>) #-} -m ==> body = m ==>@ const body -infix 1 ==> - --- | Similar to '==>@' but additionally pass caller address. -(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncode param, BEncode result) - => Monad remote - => Method param result -- ^ Signature. - -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>@) #-} -m ==>@ body = (methodName m, newbody) - where - {-# INLINE newbody #-} - newbody addr q = - case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of - Left e -> return (Left (ProtocolError (BC.pack e))) - Right a -> do - r <- body addr a - return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) - -infix 1 ==>@ - --- TODO: allow forkIO - --- | Run RPC server on specified port by using list of handlers. --- Server will dispatch procedure specified by callee, but note that --- it will not create new thread for each connection. --- -server :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port used to accept incoming connections. - -> [MethodHandler remote] -- ^ Method table. - -> remote () -server servport handlers = do - remoteServer servport $ \addr q -> do - case dispatch (queryMethod q) of - Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> m addr q - where - handlerMap = M.fromList handlers - dispatch s = M.lookup s handlerMap diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs deleted file mode 100644 index d28fdbeb..00000000 --- a/src/Remote/KRPC/Protocol.hs +++ /dev/null @@ -1,249 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides straightforward implementation of KRPC --- protocol. In many situations 'Network.KRPC' should be prefered --- since it gives more safe, convenient and high level api. --- --- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} -module Remote.KRPC.Protocol - ( -- * Error - KError(..), ErrorCode, errorCode, mkKError - - -- * Query - , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery - - -- * Response - , KResponse(respVals), ValName, kresponse - - , sendMessage, recvResponse - - -- * Remote - , KRemote, KRemoteAddr, withRemote, remoteServer - - -- * Re-exports - , encode, encoded, decode, decoded, toBEncode, fromBEncode - ) where - -import Control.Applicative -import Control.Exception.Lifted as Lifted -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Control - -import Data.BEncode -import Data.ByteString as B -import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB -import Data.Map as M - -import Network.Socket hiding (recvFrom) -import Network.Socket.ByteString - - --- | Errors used to signal that some error occurred while processing a --- procedure call. Error may be send only from server to client but --- not in the opposite direction. --- --- Errors are encoded as bencoded dictionary: --- --- > { "y" : "e", "e" : [, ] } --- -data KError - -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: ByteString } - - -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: ByteString } - - -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: ByteString } - - -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: ByteString } - deriving (Show, Read, Eq, Ord) - -instance BEncode KError where - {-# SPECIALIZE instance BEncode KError #-} - {-# INLINE toBEncode #-} - toBEncode e = fromAscAssocs -- WARN: keep keys sorted - [ "e" --> (errorCode e, errorMessage e) - , "y" --> ("e" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "e") - = uncurry mkKError <$> d >-- "e" - - fromBEncode _ = decodingError "KError" - -type ErrorCode = Int - -errorCode :: KError -> ErrorCode -errorCode (GenericError _) = 201 -errorCode (ServerError _) = 202 -errorCode (ProtocolError _) = 203 -errorCode (MethodUnknown _) = 204 -{-# INLINE errorCode #-} - -mkKError :: ErrorCode -> ByteString -> KError -mkKError 201 = GenericError -mkKError 202 = ServerError -mkKError 203 = ProtocolError -mkKError 204 = MethodUnknown -mkKError _ = GenericError -{-# INLINE mkKError #-} - -serverError :: SomeException -> KError -serverError = ServerError . BC.pack . show - --- TODO Asc everywhere - - -type MethodName = ByteString -type ParamName = ByteString - --- | Query used to signal that caller want to make procedure call to --- callee and pass arguments in. Therefore query may be only sent from --- client to server but not in the opposite direction. --- --- Queries are encoded as bencoded dictionary: --- --- > { "y" : "q", "q" : "", "a" : [, , ...] } --- -data KQuery = KQuery { - queryMethod :: MethodName - , queryArgs :: Map ParamName BValue - } deriving (Show, Read, Eq, Ord) - -instance BEncode KQuery where - {-# SPECIALIZE instance BEncode KQuery #-} - {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted - [ "a" --> BDict args - , "q" --> m - , "y" --> ("q" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "q") = - KQuery <$> d >-- "q" - <*> d >-- "a" - - fromBEncode _ = decodingError "KQuery" - -kquery :: MethodName -> [(ParamName, BValue)] -> KQuery -kquery name args = KQuery name (M.fromList args) -{-# INLINE kquery #-} - - - - -type ValName = ByteString - --- | KResponse used to signal that callee successufully process a --- procedure call and to return values from procedure. KResponse should --- not be sent if error occurred during RPC. Thus KResponse may be only --- sent from server to client. --- --- Responses are encoded as bencoded dictionary: --- --- > { "y" : "r", "r" : [, , ...] } --- -newtype KResponse = KResponse { respVals :: BDict } - deriving (Show, Read, Eq, Ord) - -instance BEncode KResponse where - {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted - [ "r" --> vals - , "y" --> ("r" :: ByteString) - ] - - {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "r") = - KResponse <$> d >-- "r" - - fromBEncode _ = decodingError "KDict" - - -kresponse :: [(ValName, BValue)] -> KResponse -kresponse = KResponse . M.fromList -{-# INLINE kresponse #-} - - - -type KRemoteAddr = (HostAddress, PortNumber) - -type KRemote = Socket - -withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) - (liftIO . sClose) -{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} - - -maxMsgSize :: Int -{-# INLINE maxMsgSize #-} --- release ---maxMsgSize = 512 -- size of payload of one udp packet --- bench -maxMsgSize = 64 * 1024 -- max udp size - - --- TODO eliminate toStrict -sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg (host, port) sock = - sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) -{-# INLINE sendMessage #-} - -recvResponse :: KRemote -> IO (Either KError KResponse) -recvResponse sock = do - (raw, _) <- recvFrom sock maxMsgSize - return $ case decoded raw of - Right resp -> Right resp - Left decE -> Left $ case decoded raw of - Right kerror -> kerror - _ -> ProtocolError (BC.pack decE) - --- | Run server using a given port. Method invocation should be done manually. -remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port number to listen. - -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) - -- ^ Handler. - -> remote () -remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop - where - bindServ = do - sock <- socket AF_INET Datagram defaultProtocol - bindSocket sock (SockAddrInet servport iNADDR_ANY) - return sock - - loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - case addr of - SockAddrInet port host -> do - let kaddr = (host, port) - reply <- handleMsg bs kaddr - liftIO $ sendMessage reply kaddr sock - _ -> return () - - where - handleMsg bs addr = case decoded bs of - Right query -> (either toBEncode toBEncode <$> action addr query) - `Lifted.catch` (return . toBEncode . serverError) - Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs deleted file mode 100644 index ebdc7740..00000000 --- a/src/Remote/KRPC/Scheme.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides message scheme validation for core protocol --- messages from 'Remote.KRPC.Procotol'. This module should be used --- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') --- this module seems to be useless. --- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -module Remote.KRPC.Scheme - ( KMessage(..) - , KQueryScheme(..), methodQueryScheme - , KResponseScheme(..), methodRespScheme - ) where - -import Control.Applicative -import Data.Map as M -import Data.Set as S - -import Remote.KRPC.Protocol -import Remote.KRPC - - --- | Used to validate any message by its scheme --- --- forall m. m `validate` scheme m --- -class KMessage message scheme | message -> scheme where - -- | Get a message scheme. - scheme :: message -> scheme - - -- | Check a message with a scheme. - validate :: message -> scheme -> Bool - - default validate :: Eq scheme => message -> scheme -> Bool - validate = (==) . scheme - {-# INLINE validate #-} - - -instance KMessage KError ErrorCode where - {-# SPECIALIZE instance KMessage KError ErrorCode #-} - scheme = errorCode - {-# INLINE scheme #-} - - -data KQueryScheme = KQueryScheme { - qscMethod :: MethodName - , qscParams :: Set ParamName - } deriving (Show, Read, Eq, Ord) - -instance KMessage KQuery KQueryScheme where - {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} - scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) - {-# INLINE scheme #-} - -methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName - <*> S.fromList . methodParams -{-# INLINE methodQueryScheme #-} - - -newtype KResponseScheme = KResponseScheme { - rscVals :: Set ValName - } deriving (Show, Read, Eq, Ord) - -instance KMessage KResponse KResponseScheme where - {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . keysSet . respVals - {-# INLINE scheme #-} - -methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . S.fromList . methodVals -{-# INLINE methodRespScheme #-} -- cgit v1.2.3 From 4bef345a5871255e12e685ca01f5cfb127ff691a Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:45:54 +0400 Subject: Update imports --- bench/Main.hs | 2 +- bench/Server.hs | 2 +- krpc.cabal | 6 +++--- src/Network/KRPC.hs | 4 ++-- src/Network/KRPC/Protocol.hs | 2 +- src/Network/KRPC/Scheme.hs | 6 +++--- tests/Client.hs | 2 +- tests/Server.hs | 2 +- tests/Shared.hs | 2 +- 9 files changed, 14 insertions(+), 14 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 697ecce9..fdf76cc2 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -5,7 +5,7 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B import Criterion.Main -import Remote.KRPC +import Network.KRPC addr :: RemoteAddr diff --git a/bench/Server.hs b/bench/Server.hs index ece5a7a9..444362c1 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.ByteString (ByteString) -import Remote.KRPC +import Network.KRPC echo :: Method ByteString ByteString diff --git a/krpc.cabal b/krpc.cabal index 0ac9faac..435f446a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -38,9 +38,9 @@ library default-extensions: PatternGuards , RecordWildCards hs-source-dirs: src - exposed-modules: Remote.KRPC - , Remote.KRPC.Protocol - , Remote.KRPC.Scheme + exposed-modules: Network.KRPC + , Network.KRPC.Protocol + , Network.KRPC.Scheme build-depends: base == 4.* , lifted-base >= 0.1.1 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 5c913daa..e667853a 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -94,7 +94,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} -module Remote.KRPC +module Network.KRPC ( -- * Method Method(..) , method, idM @@ -128,7 +128,7 @@ import Data.Typeable import Network import GHC.Generics -import Remote.KRPC.Protocol +import Network.KRPC.Protocol -- | Method datatype used to describe name, parameters and return diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index d28fdbeb..69d900cc 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -17,7 +17,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-} -module Remote.KRPC.Protocol +module Network.KRPC.Protocol ( -- * Error KError(..), ErrorCode, errorCode, mkKError diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs index ebdc7740..15f0b677 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -module Remote.KRPC.Scheme +module Network.KRPC.Scheme ( KMessage(..) , KQueryScheme(..), methodQueryScheme , KResponseScheme(..), methodRespScheme @@ -24,8 +24,8 @@ import Control.Applicative import Data.Map as M import Data.Set as S -import Remote.KRPC.Protocol -import Remote.KRPC +import Network.KRPC.Protocol +import Network.KRPC -- | Used to validate any message by its scheme diff --git a/tests/Client.hs b/tests/Client.hs index 313cd56e..db7a3219 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -14,7 +14,7 @@ import Test.HUnit hiding (Test) import Test.Framework import Test.Framework.Providers.HUnit -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Server.hs b/tests/Server.hs index aaf6d9f2..9e70b70b 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -2,7 +2,7 @@ module Main (main) where import Data.BEncode -import Remote.KRPC +import Network.KRPC import Shared diff --git a/tests/Shared.hs b/tests/Shared.hs index 1060cfc8..16547644 100644 --- a/tests/Shared.hs +++ b/tests/Shared.hs @@ -12,7 +12,7 @@ module Shared import Data.ByteString (ByteString) import Data.BEncode -import Remote.KRPC +import Network.KRPC unitM :: Method () () unitM = method "unit" [] [] -- cgit v1.2.3 From 0af7da8ec92b12081e24ece17a7e54f95ab64ad6 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:47:05 +0400 Subject: Code style --- src/Network/KRPC/Protocol.hs | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 69d900cc..77aa29e1 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -19,21 +19,38 @@ {-# LANGUAGE DefaultSignatures #-} module Network.KRPC.Protocol ( -- * Error - KError(..), ErrorCode, errorCode, mkKError + KError(..) + , ErrorCode + , errorCode + , mkKError -- * Query - , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery + , KQuery(queryMethod, queryArgs) + , MethodName + , ParamName + , kquery -- * Response - , KResponse(respVals), ValName, kresponse + , KResponse(respVals) + , ValName + , kresponse - , sendMessage, recvResponse + , sendMessage + , recvResponse -- * Remote - , KRemote, KRemoteAddr, withRemote, remoteServer + , KRemote + , KRemoteAddr + , withRemote + , remoteServer -- * Re-exports - , encode, encoded, decode, decoded, toBEncode, fromBEncode + , encode + , encoded + , decode + , decoded + , toBEncode + , fromBEncode ) where import Control.Applicative -- cgit v1.2.3 From 3a787f542b0dd8b671f174e729750821dc6015ec Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:47:30 +0400 Subject: Fix documentation markup --- src/Network/KRPC/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 77aa29e1..ad1dabca 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -9,7 +9,7 @@ -- protocol. In many situations 'Network.KRPC' should be prefered -- since it gives more safe, convenient and high level api. -- --- > See http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol +-- See -- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -- cgit v1.2.3 From 70fd99493c62e0aa085161c6890cd9bfa3ba4ad9 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:47:44 +0400 Subject: Update TODO --- TODO.org | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TODO.org b/TODO.org index e7f5c800..15022308 100644 --- a/TODO.org +++ b/TODO.org @@ -13,5 +13,5 @@ * DONE remove async api * DONE expose client addr in server-side handlers * DONE major version bump to 0.2.0.0 (reason: async API removed) -* TODO Remote.* -> Network.* +* DONE Remote.* -> Network.* * TODO ipv6 support -- cgit v1.2.3 From 4a0653fc58869f4fc61230d3d11ef92626a8f52d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 28 Sep 2013 07:49:12 +0400 Subject: Bump version --- NEWS.md | 2 ++ krpc.cabal | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 2c8f2d71..56669a70 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,3 +3,5 @@ * 0.2.0.0: Async API have been removed, use /async/ package instead. Expose caller address in handlers. * 0.2.2.0: Use bencoding-0.2.2.* +* 0.3.0.0: Use bencoding-0.3.* + Rename Remote.* to Network.* modules. diff --git a/krpc.cabal b/krpc.cabal index 435f446a..d6995410 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.2.2.0 +version: 0.3.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -31,7 +31,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.2.2.0 + tag: v0.3.0.0 library default-language: Haskell2010 -- cgit v1.2.3 From 258f21eb490ee3588dd3a1c7316ff41f7f355be7 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 1 Oct 2013 06:10:41 +0400 Subject: Allow passing ipv6 addresses --- README.md | 4 ++++ bench/Main.hs | 3 ++- bench/Server.hs | 3 ++- krpc.cabal | 4 ++++ src/Network/KRPC.hs | 9 +++++---- src/Network/KRPC/Protocol.hs | 25 ++++++++----------------- tests/Client.hs | 3 ++- tests/Server.hs | 3 ++- 8 files changed, 29 insertions(+), 25 deletions(-) diff --git a/README.md b/README.md index ccbd6789..189bda04 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,10 @@ language, thus it's hard to shoot yourself in the foot accidently. See bittorrent DHT [specification][spec] for detailed protocol description. +### Example + +TODO + #### Modules * Remote.KRPC — simple interface which reduce all RPC related stuff to diff --git a/bench/Main.hs b/bench/Main.hs index fdf76cc2..024d4d93 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -6,10 +6,11 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import Criterion.Main import Network.KRPC +import Network.Socket addr :: RemoteAddr -addr = (0, 6000) +addr = SockAddrInet 6000 0 echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] diff --git a/bench/Server.hs b/bench/Server.hs index 444362c1..ef20c08a 100644 --- a/bench/Server.hs +++ b/bench/Server.hs @@ -3,10 +3,11 @@ module Main (main) where import Data.ByteString (ByteString) import Network.KRPC +import Network.Socket echo :: Method ByteString ByteString echo = method "echo" ["x"] ["x"] main :: IO () -main = server 6000 [ echo ==> return ] +main = server (SockAddrInet 6000 0) [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal index d6995410..9929cea7 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -69,6 +69,7 @@ test-suite test-client , bencoding , krpc + , network , HUnit , test-framework @@ -84,6 +85,7 @@ executable test-server , bytestring , bencoding , krpc + , network executable bench-server default-language: Haskell2010 @@ -92,6 +94,7 @@ executable bench-server build-depends: base == 4.* , bytestring , krpc + , network ghc-options: -fforce-recomp benchmark bench-client @@ -103,4 +106,5 @@ benchmark bench-client , bytestring , criterion , krpc + , network ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index e667853a..3c9f9bee 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -97,7 +97,8 @@ module Network.KRPC ( -- * Method Method(..) - , method, idM + , method + , idM -- * Client , RemoteAddr @@ -349,11 +350,11 @@ infix 1 ==>@ -- it will not create new thread for each connection. -- server :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port used to accept incoming connections. + => KRemoteAddr -- ^ Port used to accept incoming connections. -> [MethodHandler remote] -- ^ Method table. -> remote () -server servport handlers = do - remoteServer servport $ \addr q -> do +server servAddr handlers = do + remoteServer servAddr $ \addr q -> do case dispatch (queryMethod q) of Nothing -> return $ Left $ MethodUnknown (queryMethod q) Just m -> m addr q diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index ad1dabca..2d905f06 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -202,10 +202,7 @@ kresponse :: [(ValName, BValue)] -> KResponse kresponse = KResponse . M.fromList {-# INLINE kresponse #-} - - -type KRemoteAddr = (HostAddress, PortNumber) - +type KRemoteAddr = SockAddr type KRemote = Socket withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a @@ -224,8 +221,7 @@ maxMsgSize = 64 * 1024 -- max udp size -- TODO eliminate toStrict sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg (host, port) sock = - sendAllTo sock (LB.toStrict (encoded msg)) (SockAddrInet port host) +sendMessage msg addr sock = sendAllTo sock (LB.toStrict (encoded msg)) addr {-# INLINE sendMessage #-} recvResponse :: KRemote -> IO (Either KError KResponse) @@ -239,26 +235,21 @@ recvResponse sock = do -- | Run server using a given port. Method invocation should be done manually. remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => PortNumber -- ^ Port number to listen. + => KRemoteAddr -- ^ Port number to listen. -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) -- ^ Handler. -> remote () -remoteServer servport action = bracket (liftIO bindServ) (liftIO . sClose) loop +remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where bindServ = do sock <- socket AF_INET Datagram defaultProtocol - bindSocket sock (SockAddrInet servport iNADDR_ANY) + bindSocket sock servAddr return sock loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - case addr of - SockAddrInet port host -> do - let kaddr = (host, port) - reply <- handleMsg bs kaddr - liftIO $ sendMessage reply kaddr sock - _ -> return () - + (bs, addr) <- liftIO $ recvFrom sock maxMsgSize + reply <- handleMsg bs addr + liftIO $ sendMessage reply addr sock where handleMsg bs addr = case decoded bs of Right query -> (either toBEncode toBEncode <$> action addr query) diff --git a/tests/Client.hs b/tests/Client.hs index db7a3219..cda01631 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -15,11 +15,12 @@ import Test.Framework import Test.Framework.Providers.HUnit import Network.KRPC +import Network.Socket import Shared addr :: RemoteAddr -addr = (0, 6000) +addr = SockAddrInet 6000 0 withServ :: FilePath -> IO () -> IO () withServ serv_path = bracket up terminateProcess . const diff --git a/tests/Server.hs b/tests/Server.hs index 9e70b70b..b4b34891 100644 --- a/tests/Server.hs +++ b/tests/Server.hs @@ -3,11 +3,12 @@ module Main (main) where import Data.BEncode import Network.KRPC +import Network.Socket import Shared main :: IO () -main = server 6000 +main = server (SockAddrInet 6000 0) [ unitM ==> return , echoM ==> return , echoBytes ==> return -- cgit v1.2.3 From fbecd1c50e3b2d721b9c0dd7050680f7fef7294e Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 1 Oct 2013 06:11:00 +0400 Subject: Stylefix --- src/Network/KRPC/Protocol.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 2d905f06..108c47c4 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -242,9 +242,9 @@ remoteServer :: (MonadBaseControl IO remote, MonadIO remote) remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where bindServ = do - sock <- socket AF_INET Datagram defaultProtocol - bindSocket sock servAddr - return sock + sock <- socket AF_INET Datagram defaultProtocol + bindSocket sock servAddr + return sock loop sock = forever $ do (bs, addr) <- liftIO $ recvFrom sock maxMsgSize -- cgit v1.2.3 From 908a20ca2880a9047f7fbf07e33f18caf53f5109 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 15:36:30 +0400 Subject: IPv6 enabled communication --- src/Network/KRPC/Protocol.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 108c47c4..32065ff7 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -205,19 +205,20 @@ kresponse = KResponse . M.fromList type KRemoteAddr = SockAddr type KRemote = Socket +sockAddrFamily :: SockAddr -> Family +sockAddrFamily (SockAddrInet _ _ ) = AF_INET +sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +sockAddrFamily (SockAddrUnix _ ) = AF_UNIX + withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET Datagram defaultProtocol)) +withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) (liftIO . sClose) {-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} - maxMsgSize :: Int +--maxMsgSize = 512 -- release: size of payload of one udp packet +maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# INLINE maxMsgSize #-} --- release ---maxMsgSize = 512 -- size of payload of one udp packet --- bench -maxMsgSize = 64 * 1024 -- max udp size - -- TODO eliminate toStrict sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () @@ -242,7 +243,10 @@ remoteServer :: (MonadBaseControl IO remote, MonadIO remote) remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where bindServ = do - sock <- socket AF_INET Datagram defaultProtocol + let family = sockAddrFamily servAddr + sock <- socket family Datagram defaultProtocol + when (family == AF_INET6) $ do + setSocketOption sock IPv6Only 0 bindSocket sock servAddr return sock -- cgit v1.2.3 From d8bec96d7ff43453f5ddda470ac80346a6c7e3c1 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 15:56:31 +0400 Subject: Eliminate bytestring copying in sendMessage function --- src/Network/KRPC/Protocol.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 32065ff7..71f5b773 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -220,9 +220,8 @@ maxMsgSize :: Int maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# INLINE maxMsgSize #-} --- TODO eliminate toStrict sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg addr sock = sendAllTo sock (LB.toStrict (encoded msg)) addr +sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encoded msg)) addr {-# INLINE sendMessage #-} recvResponse :: KRemote -> IO (Either KError KResponse) -- cgit v1.2.3 From a5ad6913d358f199fa4205ab3c52c2ca24d9c8dc Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 15:57:21 +0400 Subject: Remove obsolete TODOs --- src/Network/KRPC.hs | 2 -- src/Network/KRPC/Protocol.hs | 2 -- 2 files changed, 4 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 3c9f9bee..0428669b 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -343,8 +343,6 @@ m ==>@ body = (methodName m, newbody) infix 1 ==>@ --- TODO: allow forkIO - -- | Run RPC server on specified port by using list of handlers. -- Server will dispatch procedure specified by callee, but note that -- it will not create new thread for each connection. diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 71f5b773..1e7bd7c3 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -126,8 +126,6 @@ mkKError _ = GenericError serverError :: SomeException -> KError serverError = ServerError . BC.pack . show --- TODO Asc everywhere - type MethodName = ByteString type ParamName = ByteString -- cgit v1.2.3 From b6a1a6969f36385b3e25e6844c6d7c835476382b Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 16:24:46 +0400 Subject: Rename NEWS.md to CHANGELOG --- CHANGELOG | 7 +++++++ NEWS.md | 7 ------- krpc.cabal | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG delete mode 100644 NEWS.md diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 00000000..56669a70 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,7 @@ +* 0.1.0.0: Initial version. +* 0.1.1.0: Allow passing raw argument\/result dictionaries. +* 0.2.0.0: Async API have been removed, use /async/ package instead. + Expose caller address in handlers. +* 0.2.2.0: Use bencoding-0.2.2.* +* 0.3.0.0: Use bencoding-0.3.* + Rename Remote.* to Network.* modules. diff --git a/NEWS.md b/NEWS.md deleted file mode 100644 index 56669a70..00000000 --- a/NEWS.md +++ /dev/null @@ -1,7 +0,0 @@ -* 0.1.0.0: Initial version. -* 0.1.1.0: Allow passing raw argument\/result dictionaries. -* 0.2.0.0: Async API have been removed, use /async/ package instead. - Expose caller address in handlers. -* 0.2.2.0: Use bencoding-0.2.2.* -* 0.3.0.0: Use bencoding-0.3.* - Rename Remote.* to Network.* modules. diff --git a/krpc.cabal b/krpc.cabal index 9929cea7..0bba1a9c 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -20,7 +20,7 @@ description: See NEWS.md for release notes. extra-source-files: README.md - , NEWS.md + , CHANGELOG source-repository head type: git -- cgit v1.2.3 From 51eda92ddee86f49cbc458e6b7858cff72c7f304 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 16:38:25 +0400 Subject: Bump version --- CHANGELOG | 1 + TODO.org | 2 +- krpc.cabal | 4 ++-- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 56669a70..44886bb0 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -5,3 +5,4 @@ * 0.2.2.0: Use bencoding-0.2.2.* * 0.3.0.0: Use bencoding-0.3.* Rename Remote.* to Network.* modules. +* 0.4.0.0: IPv6 support. \ No newline at end of file diff --git a/TODO.org b/TODO.org index 15022308..19904f73 100644 --- a/TODO.org +++ b/TODO.org @@ -14,4 +14,4 @@ * DONE expose client addr in server-side handlers * DONE major version bump to 0.2.0.0 (reason: async API removed) * DONE Remote.* -> Network.* -* TODO ipv6 support +* DONE ipv6 support diff --git a/krpc.cabal b/krpc.cabal index 0bba1a9c..2a4c863a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.3.0.0 +version: 0.4.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -31,7 +31,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.3.0.0 + tag: v0.4.0.0 library default-language: Haskell2010 -- cgit v1.2.3 From fd75db797f09f05d6265232557e216ba4dd04959 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 16:47:13 +0400 Subject: Move CHANGELOG to changelog --- CHANGELOG | 8 -------- changelog | 8 ++++++++ krpc.cabal | 4 +--- 3 files changed, 9 insertions(+), 11 deletions(-) delete mode 100644 CHANGELOG create mode 100644 changelog diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 index 44886bb0..00000000 --- a/CHANGELOG +++ /dev/null @@ -1,8 +0,0 @@ -* 0.1.0.0: Initial version. -* 0.1.1.0: Allow passing raw argument\/result dictionaries. -* 0.2.0.0: Async API have been removed, use /async/ package instead. - Expose caller address in handlers. -* 0.2.2.0: Use bencoding-0.2.2.* -* 0.3.0.0: Use bencoding-0.3.* - Rename Remote.* to Network.* modules. -* 0.4.0.0: IPv6 support. \ No newline at end of file diff --git a/changelog b/changelog new file mode 100644 index 00000000..44886bb0 --- /dev/null +++ b/changelog @@ -0,0 +1,8 @@ +* 0.1.0.0: Initial version. +* 0.1.1.0: Allow passing raw argument\/result dictionaries. +* 0.2.0.0: Async API have been removed, use /async/ package instead. + Expose caller address in handlers. +* 0.2.2.0: Use bencoding-0.2.2.* +* 0.3.0.0: Use bencoding-0.3.* + Rename Remote.* to Network.* modules. +* 0.4.0.0: IPv6 support. \ No newline at end of file diff --git a/krpc.cabal b/krpc.cabal index 2a4c863a..05237cb8 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -16,11 +16,9 @@ synopsis: KRPC remote procedure call protocol implementation. description: KRPC remote procedure call protocol implementation. - . - See NEWS.md for release notes. extra-source-files: README.md - , CHANGELOG + , changelog source-repository head type: git -- cgit v1.2.3 From 3d61d2d9b12bc41853aa388048da96460b34605d Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 3 Oct 2013 16:52:34 +0400 Subject: Bump version --- changelog | 3 ++- krpc.cabal | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/changelog b/changelog index 44886bb0..0d89e4a6 100644 --- a/changelog +++ b/changelog @@ -5,4 +5,5 @@ * 0.2.2.0: Use bencoding-0.2.2.* * 0.3.0.0: Use bencoding-0.3.* Rename Remote.* to Network.* modules. -* 0.4.0.0: IPv6 support. \ No newline at end of file +* 0.4.0.0: IPv6 support. +* 0.4.0.1: Minor documentation fixes. diff --git a/krpc.cabal b/krpc.cabal index 05237cb8..96098537 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.4.0.0 +version: 0.4.0.1 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -29,7 +29,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.4.0.0 + tag: v0.4.0.1 library default-language: Haskell2010 -- cgit v1.2.3 From 2f5450c06b70b5d9b319d651af5934aa4e5f97c4 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:49:42 +0400 Subject: Update library to use bencoding == 0.4.* --- krpc.cabal | 2 +- src/Network/KRPC.hs | 22 +++++++----- src/Network/KRPC/Protocol.hs | 81 ++++++++++++++++++++++---------------------- src/Network/KRPC/Scheme.hs | 22 +++++++----- 4 files changed, 69 insertions(+), 58 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 96098537..68025f43 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -47,7 +47,7 @@ library , bytestring >= 0.10 , containers >= 0.4 - , bencoding == 0.3.* + , bencoding == 0.4.* , network >= 2.3 ghc-options: -Wall diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 0428669b..27363515 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -120,7 +120,9 @@ import Control.Applicative import Control.Exception import Control.Monad.Trans.Control import Control.Monad.IO.Class -import Data.BEncode +import Data.BEncode as BE +import Data.BEncode.BDict as BE +import Data.BEncode.Types as BE import Data.ByteString.Char8 as BC import Data.List as L import Data.Map as M @@ -226,20 +228,24 @@ method = Method {-# INLINE method #-} lookupKey :: ParamName -> BDict -> Result BValue -lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . M.lookup x +lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . BE.lookup x extractArgs :: [ParamName] -> BDict -> Result BValue -extractArgs [] d = Right $ if M.null d then BList [] else BDict d +extractArgs [] d = Right $ if BE.null d then BList [] else BDict d extractArgs [x] d = lookupKey x d extractArgs xs d = BList <$> mapM (`lookupKey` d) xs {-# INLINE extractArgs #-} -injectVals :: [ParamName] -> BValue -> [(ParamName, BValue)] -injectVals [] (BList []) = [] -injectVals [] (BDict d ) = M.toList d +zipBDict :: [BKey] -> [BValue] -> BDict +zipBDict (k : ks) (v : vs) = Cons k v (zipBDict ks vs) +zipBDict _ _ = Nil + +injectVals :: [ParamName] -> BValue -> BDict +injectVals [] (BList []) = BE.empty +injectVals [] (BDict d ) = d injectVals [] be = invalidParamList [] be -injectVals [p] arg = [(p, arg)] -injectVals ps (BList as) = L.zip ps as +injectVals [p] arg = BE.singleton p arg +injectVals ps (BList as) = zipBDict ps as injectVals ps be = invalidParamList ps be {-# INLINE injectVals #-} diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 1e7bd7c3..67a4057d 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -17,6 +17,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} module Network.KRPC.Protocol ( -- * Error KError(..) @@ -46,9 +47,7 @@ module Network.KRPC.Protocol -- * Re-exports , encode - , encoded , decode - , decoded , toBEncode , fromBEncode ) where @@ -59,11 +58,14 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control -import Data.BEncode +import Data.BEncode as BE +import Data.BEncode.BDict as BE +import Data.BEncode.Types as BE import Data.ByteString as B import Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB import Data.Map as M +import Data.Typeable import Network.Socket hiding (recvFrom) import Network.Socket.ByteString @@ -89,20 +91,21 @@ data KError -- | Occur when client trying to call method server don't know. | MethodUnknown { errorMessage :: ByteString } - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KError where {-# SPECIALIZE instance BEncode KError #-} {-# INLINE toBEncode #-} - toBEncode e = fromAscAssocs -- WARN: keep keys sorted - [ "e" --> (errorCode e, errorMessage e) - , "y" --> ("e" :: ByteString) - ] + toBEncode e = toDict $ + "e" .=! (errorCode e, errorMessage e) + .: "y" .=! ("e" :: ByteString) + .: endDict {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "e") - = uncurry mkKError <$> d >-- "e" + fromBEncode be @ (BDict d) + | BE.lookup "y" d == Just (BString "e") + = (`fromDict` be) $ do + uncurry mkKError <$>! "e" fromBEncode _ = decodingError "KError" @@ -140,33 +143,30 @@ type ParamName = ByteString -- data KQuery = KQuery { queryMethod :: MethodName - , queryArgs :: Map ParamName BValue - } deriving (Show, Read, Eq, Ord) + , queryArgs :: BDict + } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KQuery where {-# SPECIALIZE instance BEncode KQuery #-} {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = fromAscAssocs -- WARN: keep keys sorted - [ "a" --> BDict args - , "q" --> m - , "y" --> ("q" :: ByteString) - ] + toBEncode (KQuery m args) = toDict $ + "a" .=! BDict args + .: "q" .=! m + .: "y" .=! ("q" :: ByteString) + .: endDict {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "q") = - KQuery <$> d >-- "q" - <*> d >-- "a" + fromBEncode bv @ (BDict d) + | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do + KQuery <$>! "q" <*>! "a" fromBEncode _ = decodingError "KQuery" -kquery :: MethodName -> [(ParamName, BValue)] -> KQuery -kquery name args = KQuery name (M.fromList args) +kquery :: MethodName -> BDict -> KQuery +kquery = KQuery {-# INLINE kquery #-} - - type ValName = ByteString -- | KResponse used to signal that callee successufully process a @@ -179,25 +179,24 @@ type ValName = ByteString -- > { "y" : "r", "r" : [, , ...] } -- newtype KResponse = KResponse { respVals :: BDict } - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KResponse where {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = fromAscAssocs -- WARN: keep keys sorted - [ "r" --> vals - , "y" --> ("r" :: ByteString) - ] + toBEncode (KResponse vals) = toDict $ + "r" .=! vals + .: "y" .=! ("r" :: ByteString) + .: endDict {-# INLINE fromBEncode #-} - fromBEncode (BDict d) - | M.lookup "y" d == Just (BString "r") = - KResponse <$> d >-- "r" + fromBEncode bv @ (BDict d) + | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do + KResponse <$>! "r" fromBEncode _ = decodingError "KDict" - -kresponse :: [(ValName, BValue)] -> KResponse -kresponse = KResponse . M.fromList +kresponse :: BDict -> KResponse +kresponse = KResponse {-# INLINE kresponse #-} type KRemoteAddr = SockAddr @@ -219,15 +218,15 @@ maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# INLINE maxMsgSize #-} sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () -sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encoded msg)) addr +sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr {-# INLINE sendMessage #-} recvResponse :: KRemote -> IO (Either KError KResponse) recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize - return $ case decoded raw of + return $ case decode raw of Right resp -> Right resp - Left decE -> Left $ case decoded raw of + Left decE -> Left $ case decode raw of Right kerror -> kerror _ -> ProtocolError (BC.pack decE) @@ -252,7 +251,7 @@ remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop reply <- handleMsg bs addr liftIO $ sendMessage reply addr sock where - handleMsg bs addr = case decoded bs of + handleMsg bs addr = case decode bs of Right query -> (either toBEncode toBEncode <$> action addr query) `Lifted.catch` (return . toBEncode . serverError) Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs index 15f0b677..59d2c627 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -21,6 +21,9 @@ module Network.KRPC.Scheme ) where import Control.Applicative +import Data.BEncode as BE +import Data.BEncode.BDict as BS +import Data.BEncode.Types as BS import Data.Map as M import Data.Set as S @@ -45,19 +48,23 @@ class KMessage message scheme | message -> scheme where instance KMessage KError ErrorCode where - {-# SPECIALIZE instance KMessage KError ErrorCode #-} scheme = errorCode {-# INLINE scheme #-} - data KQueryScheme = KQueryScheme { qscMethod :: MethodName , qscParams :: Set ParamName } deriving (Show, Read, Eq, Ord) +bdictKeys :: BDict -> [BKey] +bdictKeys (Cons k _ xs) = k : bdictKeys xs +bdictKeys Nil = [] + instance KMessage KQuery KQueryScheme where - {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-} - scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q)) + scheme q = KQueryScheme + { qscMethod = queryMethod q + , qscParams = S.fromAscList $ bdictKeys $ queryArgs q + } {-# INLINE scheme #-} methodQueryScheme :: Method a b -> KQueryScheme @@ -65,14 +72,13 @@ methodQueryScheme = KQueryScheme <$> methodName <*> S.fromList . methodParams {-# INLINE methodQueryScheme #-} - -newtype KResponseScheme = KResponseScheme { - rscVals :: Set ValName +newtype KResponseScheme = KResponseScheme + { rscVals :: Set ValName } deriving (Show, Read, Eq, Ord) instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . keysSet . respVals + scheme = KResponseScheme . S.fromAscList . bdictKeys . respVals {-# INLINE scheme #-} methodRespScheme :: Method a b -> KResponseScheme -- cgit v1.2.3 From 913915b3e2b88305c7e4eeeee2c4191465970655 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:52:34 +0400 Subject: Update tests to use newer bencoding --- tests/Client.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/tests/Client.hs b/tests/Client.hs index cda01631..b92f7094 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -4,9 +4,8 @@ module Main (main) where import Control.Concurrent import Control.Exception import qualified Data.ByteString as B -import Data.BEncode -import Data.Map -import System.Environment +import Data.BEncode as BE +import Data.BEncode.BDict as BE import System.Process import System.FilePath @@ -73,7 +72,7 @@ tests = BInteger 10 ==? call addr rawM (BInteger 10) , testCase "raw dict" $ - let dict = BDict $ fromList + let dict = BDict $ BE.fromAscList [ ("some_int", BInteger 100) , ("some_list", BList [BInteger 10]) ] -- cgit v1.2.3 From 8a56cbad9a7017d0e372c2e101e60f4b67ce4204 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:53:22 +0400 Subject: Remove orphan dependencies --- krpc.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index 68025f43..dc19f8e0 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -61,7 +61,6 @@ test-suite test-client other-modules: Shared build-depends: base == 4.* , bytestring - , containers , process , filepath -- cgit v1.2.3 From b064c9ebc2aecb2846ca0083a3a516d4cd618b29 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:54:11 +0400 Subject: Fix warnings --- src/Network/KRPC/Protocol.hs | 1 - src/Network/KRPC/Scheme.hs | 2 -- 2 files changed, 3 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 67a4057d..709429e3 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -64,7 +64,6 @@ import Data.BEncode.Types as BE import Data.ByteString as B import Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB -import Data.Map as M import Data.Typeable import Network.Socket hiding (recvFrom) diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs index 59d2c627..9d8a1876 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -21,10 +21,8 @@ module Network.KRPC.Scheme ) where import Control.Applicative -import Data.BEncode as BE import Data.BEncode.BDict as BS import Data.BEncode.Types as BS -import Data.Map as M import Data.Set as S import Network.KRPC.Protocol -- cgit v1.2.3 From 5ad4603614704bcca92a89ecf655d6a551f4f8ac Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 09:59:20 +0400 Subject: Remove containers dependency --- krpc.cabal | 3 +-- src/Network/KRPC.hs | 6 +----- src/Network/KRPC/Scheme.hs | 14 ++++++-------- 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index dc19f8e0..37f0a935 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -40,13 +40,12 @@ library , Network.KRPC.Protocol , Network.KRPC.Scheme build-depends: base == 4.* + , bytestring >= 0.10 , lifted-base >= 0.1.1 , transformers >= 0.2 , monad-control >= 0.3 - , bytestring >= 0.10 - , containers >= 0.4 , bencoding == 0.4.* , network >= 2.3 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 27363515..b6e14bb0 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -125,7 +125,6 @@ import Data.BEncode.BDict as BE import Data.BEncode.Types as BE import Data.ByteString.Char8 as BC import Data.List as L -import Data.Map as M import Data.Monoid import Data.Typeable import Network @@ -359,9 +358,6 @@ server :: (MonadBaseControl IO remote, MonadIO remote) -> remote () server servAddr handlers = do remoteServer servAddr $ \addr q -> do - case dispatch (queryMethod q) of + case L.lookup (queryMethod q) handlers of Nothing -> return $ Left $ MethodUnknown (queryMethod q) Just m -> m addr q - where - handlerMap = M.fromList handlers - dispatch s = M.lookup s handlerMap diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs index 9d8a1876..244f035d 100644 --- a/src/Network/KRPC/Scheme.hs +++ b/src/Network/KRPC/Scheme.hs @@ -23,7 +23,6 @@ module Network.KRPC.Scheme import Control.Applicative import Data.BEncode.BDict as BS import Data.BEncode.Types as BS -import Data.Set as S import Network.KRPC.Protocol import Network.KRPC @@ -51,7 +50,7 @@ instance KMessage KError ErrorCode where data KQueryScheme = KQueryScheme { qscMethod :: MethodName - , qscParams :: Set ParamName + , qscParams :: [ParamName] } deriving (Show, Read, Eq, Ord) bdictKeys :: BDict -> [BKey] @@ -61,24 +60,23 @@ bdictKeys Nil = [] instance KMessage KQuery KQueryScheme where scheme q = KQueryScheme { qscMethod = queryMethod q - , qscParams = S.fromAscList $ bdictKeys $ queryArgs q + , qscParams = bdictKeys $ queryArgs q } {-# INLINE scheme #-} methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName - <*> S.fromList . methodParams +methodQueryScheme = KQueryScheme <$> methodName <*> methodParams {-# INLINE methodQueryScheme #-} newtype KResponseScheme = KResponseScheme - { rscVals :: Set ValName + { rscVals :: [ValName] } deriving (Show, Read, Eq, Ord) instance KMessage KResponse KResponseScheme where {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . S.fromAscList . bdictKeys . respVals + scheme = KResponseScheme . bdictKeys . respVals {-# INLINE scheme #-} methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . S.fromList . methodVals +methodRespScheme = KResponseScheme . methodVals {-# INLINE methodRespScheme #-} -- cgit v1.2.3 From ee677c16e0e097c4ac2785de031f439e38dbf778 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 10:02:01 +0400 Subject: Fix bug after migration --- src/Network/KRPC/Protocol.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 709429e3..7442d990 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -157,7 +157,9 @@ instance BEncode KQuery where {-# INLINE fromBEncode #-} fromBEncode bv @ (BDict d) | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do - KQuery <$>! "q" <*>! "a" + a <- field (req "a") + q <- field (req "q") + return $! KQuery q a fromBEncode _ = decodingError "KQuery" -- cgit v1.2.3 From 3c9a4b8ab83e201c58e56b070b2d6279cc84d139 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 10:05:11 +0400 Subject: Strictify intermediate datatypes --- src/Network/KRPC/Protocol.hs | 16 +++++----------- 1 file changed, 5 insertions(+), 11 deletions(-) diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 7442d990..16027362 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -44,12 +44,6 @@ module Network.KRPC.Protocol , KRemoteAddr , withRemote , remoteServer - - -- * Re-exports - , encode - , decode - , toBEncode - , fromBEncode ) where import Control.Applicative @@ -80,16 +74,16 @@ import Network.Socket.ByteString -- data KError -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: ByteString } + = GenericError { errorMessage :: !ByteString } -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: ByteString } + | ServerError { errorMessage :: !ByteString } -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: ByteString } + | ProtocolError { errorMessage :: !ByteString } -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: ByteString } + | MethodUnknown { errorMessage :: !ByteString } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KError where @@ -141,7 +135,7 @@ type ParamName = ByteString -- > { "y" : "q", "q" : "", "a" : [, , ...] } -- data KQuery = KQuery { - queryMethod :: MethodName + queryMethod :: !MethodName , queryArgs :: BDict } deriving (Show, Read, Eq, Ord, Typeable) -- cgit v1.2.3 From f17ade7e838e92d3c132a2a21614f546888df7b3 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 17 Oct 2013 10:06:38 +0400 Subject: Bump version number to 0.4.1.0 --- changelog | 1 + krpc.cabal | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/changelog b/changelog index 0d89e4a6..6feec662 100644 --- a/changelog +++ b/changelog @@ -7,3 +7,4 @@ Rename Remote.* to Network.* modules. * 0.4.0.0: IPv6 support. * 0.4.0.1: Minor documentation fixes. +* 0.4.1.0: Use bencoding-0.4.* diff --git a/krpc.cabal b/krpc.cabal index 37f0a935..2dad90d3 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.4.0.1 +version: 0.4.1.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -29,7 +29,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.4.0.1 + tag: v0.4.1.0 library default-language: Haskell2010 -- cgit v1.2.3 From 03a660d222cc9c608ba407a540d8d3ee8cdb63bf Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 26 Nov 2013 08:22:51 +0400 Subject: Depend on ghc-prim package if ghc < 7.6 --- krpc.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/krpc.cabal b/krpc.cabal index 2dad90d3..224fe2d5 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -49,6 +49,10 @@ library , bencoding == 0.4.* , network >= 2.3 + + if impl(ghc < 7.6) + build-depends: ghc-prim + ghc-options: -Wall -- cgit v1.2.3 From eeb483b31eb4c19d68fc7f9d15f739ba0b45d21e Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 26 Nov 2013 08:35:32 +0400 Subject: Bump version number to 0.4.1.1 --- changelog | 1 + krpc.cabal | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/changelog b/changelog index 6feec662..edbd7faa 100644 --- a/changelog +++ b/changelog @@ -8,3 +8,4 @@ * 0.4.0.0: IPv6 support. * 0.4.0.1: Minor documentation fixes. * 0.4.1.0: Use bencoding-0.4.* +* 0.4.1.1: Fixed build failure on GHC == 7.4.* diff --git a/krpc.cabal b/krpc.cabal index 224fe2d5..43c4b5f0 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.4.1.0 +version: 0.4.1.1 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -29,7 +29,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.4.1.0 + tag: v0.4.1.1 library default-language: Haskell2010 -- cgit v1.2.3 From 4079232075cc35c63bc4d069d9731ec4f57edfdf Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 26 Nov 2013 08:38:32 +0400 Subject: Ignore upload-docs script --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 316009b8..c9a360e7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ dist cabal-dev +upload-docs -- cgit v1.2.3 From f349e9427db4a1b35d0af6801f6ad00b8a17991e Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 01:50:38 +0400 Subject: Remove useless type synonyms --- src/Network/KRPC.hs | 41 +++++++++++------------------------------ src/Network/KRPC/Protocol.hs | 20 ++++++++------------ tests/Client.hs | 2 +- 3 files changed, 20 insertions(+), 43 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index b6e14bb0..8cc3fcab 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -101,8 +101,6 @@ module Network.KRPC , idM -- * Client - , RemoteAddr - , RPCException(..) , call -- * Server @@ -128,6 +126,7 @@ import Data.List as L import Data.Monoid import Data.Typeable import Network +import Network.Socket import GHC.Generics import Network.KRPC.Protocol @@ -253,46 +252,28 @@ invalidParamList pl be = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ "while procedure args are: " ++ show be --- | Alias to Socket, through might change in future. -type Remote = Socket - --- | Represent any error mentioned by protocol specification that --- 'call', 'await' might throw. --- For more details see 'Remote.KRPC.Protocol'. --- -data RPCException = RPCException KError - deriving (Show, Eq, Typeable) - -instance Exception RPCException - --- | Address of remote can be called by client. -type RemoteAddr = KRemoteAddr - -queryCall :: BEncode param - => KRemote -> KRemoteAddr +queryCall :: BEncode param => Socket -> SockAddr -> Method param result -> param -> IO () queryCall sock addr m arg = sendMessage q addr sock where q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) -getResult :: BEncode result - => KRemote - -> Method param result -> IO result +getResult :: BEncode result => Socket -> Method param result -> IO result getResult sock m = do resp <- recvResponse sock case resp of - Left e -> throw (RPCException e) + Left e -> throw e Right (respVals -> dict) -> do case fromBEncode =<< extractArgs (methodVals m) dict of Right vals -> return vals - Left e -> throw (RPCException (ProtocolError (BC.pack e))) + Left e -> throw (ProtocolError (BC.pack e)) -- | Makes remote procedure call. Throws RPCException on any error -- occurred. call :: (MonadBaseControl IO host, MonadIO host) => (BEncode param, BEncode result) - => RemoteAddr -- ^ Address of callee. + => SockAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. -> host result -- ^ Values returned by callee from the procedure. @@ -301,8 +282,8 @@ call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg -- | The same as 'call' but use already opened socket. call_ :: (MonadBaseControl IO host, MonadIO host) => (BEncode param, BEncode result) - => Remote -- ^ Socket to use - -> RemoteAddr -- ^ Address of callee. + => Socket -- ^ Socket to use + -> SockAddr -- ^ Address of callee. -> Method param result -- ^ Procedure to call. -> param -- ^ Arguments passed by callee to procedure. -> host result -- ^ Values returned by callee from the procedure. @@ -311,7 +292,7 @@ call_ sock addr m arg = liftIO $ do getResult sock m -type HandlerBody remote = KRemoteAddr -> KQuery -> remote (Either KError KResponse) +type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) @@ -333,7 +314,7 @@ infix 1 ==> (BEncode param, BEncode result) => Monad remote => Method param result -- ^ Signature. - -> (KRemoteAddr -> param -> remote result) -- ^ Implementation. + -> (SockAddr -> param -> remote result) -- ^ Implementation. -> MethodHandler remote -- ^ Handler used by server. {-# INLINE (==>@) #-} m ==>@ body = (methodName m, newbody) @@ -353,7 +334,7 @@ infix 1 ==>@ -- it will not create new thread for each connection. -- server :: (MonadBaseControl IO remote, MonadIO remote) - => KRemoteAddr -- ^ Port used to accept incoming connections. + => SockAddr -- ^ Port used to accept incoming connections. -> [MethodHandler remote] -- ^ Method table. -> remote () server servAddr handlers = do diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 16027362..adc02b5f 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -40,8 +40,6 @@ module Network.KRPC.Protocol , recvResponse -- * Remote - , KRemote - , KRemoteAddr , withRemote , remoteServer ) where @@ -102,6 +100,8 @@ instance BEncode KError where fromBEncode _ = decodingError "KError" +instance Exception KError + type ErrorCode = Int errorCode :: KError -> ErrorCode @@ -194,29 +194,26 @@ kresponse :: BDict -> KResponse kresponse = KResponse {-# INLINE kresponse #-} -type KRemoteAddr = SockAddr -type KRemote = Socket - sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX -withRemote :: (MonadBaseControl IO m, MonadIO m) => (KRemote -> m a) -> m a +withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) (liftIO . sClose) -{-# SPECIALIZE withRemote :: (KRemote -> IO a) -> IO a #-} +{-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} maxMsgSize :: Int --maxMsgSize = 512 -- release: size of payload of one udp packet maxMsgSize = 64 * 1024 -- bench: max UDP MTU {-# INLINE maxMsgSize #-} -sendMessage :: BEncode msg => msg -> KRemoteAddr -> KRemote -> IO () +sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr {-# INLINE sendMessage #-} -recvResponse :: KRemote -> IO (Either KError KResponse) +recvResponse :: Socket -> IO (Either KError KResponse) recvResponse sock = do (raw, _) <- recvFrom sock maxMsgSize return $ case decode raw of @@ -227,9 +224,8 @@ recvResponse sock = do -- | Run server using a given port. Method invocation should be done manually. remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => KRemoteAddr -- ^ Port number to listen. - -> (KRemoteAddr -> KQuery -> remote (Either KError KResponse)) - -- ^ Handler. + => SockAddr -- ^ Port number to listen. + -> (SockAddr -> KQuery -> remote (Either KError KResponse)) -> remote () remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where diff --git a/tests/Client.hs b/tests/Client.hs index b92f7094..2b49bd82 100644 --- a/tests/Client.hs +++ b/tests/Client.hs @@ -18,7 +18,7 @@ import Network.Socket import Shared -addr :: RemoteAddr +addr :: SockAddr addr = SockAddrInet 6000 0 withServ :: FilePath -> IO () -> IO () -- cgit v1.2.3 From 69c1dc3c0e2a18ed43018fdbdd63bfe1a2212618 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 02:26:23 +0400 Subject: Remove Scheme module --- krpc.cabal | 1 - src/Network/KRPC.hs | 2 +- src/Network/KRPC/Scheme.hs | 82 ---------------------------------------------- 3 files changed, 1 insertion(+), 84 deletions(-) delete mode 100644 src/Network/KRPC/Scheme.hs diff --git a/krpc.cabal b/krpc.cabal index 43c4b5f0..e44f5d90 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -38,7 +38,6 @@ library hs-source-dirs: src exposed-modules: Network.KRPC , Network.KRPC.Protocol - , Network.KRPC.Scheme build-depends: base == 4.* , bytestring >= 0.10 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 8cc3fcab..f891d5a0 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -334,7 +334,7 @@ infix 1 ==>@ -- it will not create new thread for each connection. -- server :: (MonadBaseControl IO remote, MonadIO remote) - => SockAddr -- ^ Port used to accept incoming connections. + => SockAddr -- ^ Port used to accept incoming connections. -> [MethodHandler remote] -- ^ Method table. -> remote () server servAddr handlers = do diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs deleted file mode 100644 index 244f035d..00000000 --- a/src/Network/KRPC/Scheme.hs +++ /dev/null @@ -1,82 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides message scheme validation for core protocol --- messages from 'Remote.KRPC.Procotol'. This module should be used --- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') --- this module seems to be useless. --- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -module Network.KRPC.Scheme - ( KMessage(..) - , KQueryScheme(..), methodQueryScheme - , KResponseScheme(..), methodRespScheme - ) where - -import Control.Applicative -import Data.BEncode.BDict as BS -import Data.BEncode.Types as BS - -import Network.KRPC.Protocol -import Network.KRPC - - --- | Used to validate any message by its scheme --- --- forall m. m `validate` scheme m --- -class KMessage message scheme | message -> scheme where - -- | Get a message scheme. - scheme :: message -> scheme - - -- | Check a message with a scheme. - validate :: message -> scheme -> Bool - - default validate :: Eq scheme => message -> scheme -> Bool - validate = (==) . scheme - {-# INLINE validate #-} - - -instance KMessage KError ErrorCode where - scheme = errorCode - {-# INLINE scheme #-} - -data KQueryScheme = KQueryScheme { - qscMethod :: MethodName - , qscParams :: [ParamName] - } deriving (Show, Read, Eq, Ord) - -bdictKeys :: BDict -> [BKey] -bdictKeys (Cons k _ xs) = k : bdictKeys xs -bdictKeys Nil = [] - -instance KMessage KQuery KQueryScheme where - scheme q = KQueryScheme - { qscMethod = queryMethod q - , qscParams = bdictKeys $ queryArgs q - } - {-# INLINE scheme #-} - -methodQueryScheme :: Method a b -> KQueryScheme -methodQueryScheme = KQueryScheme <$> methodName <*> methodParams -{-# INLINE methodQueryScheme #-} - -newtype KResponseScheme = KResponseScheme - { rscVals :: [ValName] - } deriving (Show, Read, Eq, Ord) - -instance KMessage KResponse KResponseScheme where - {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} - scheme = KResponseScheme . bdictKeys . respVals - {-# INLINE scheme #-} - -methodRespScheme :: Method a b -> KResponseScheme -methodRespScheme = KResponseScheme . methodVals -{-# INLINE methodRespScheme #-} -- cgit v1.2.3 From 8048000a4ce6df959f2fd5f6fd4fe70cff579d15 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 17:07:15 +0400 Subject: Remove param names from Method datatype --- krpc.cabal | 40 ++++---- src/Network/KRPC.hs | 217 +++++++++---------------------------------- src/Network/KRPC/Protocol.hs | 28 ++---- 3 files changed, 75 insertions(+), 210 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index e44f5d90..28c2eaae 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -75,26 +75,26 @@ test-suite test-client , test-framework-hunit -executable test-server - default-language: Haskell2010 - hs-source-dirs: tests - main-is: Server.hs - other-modules: Shared - build-depends: base == 4.* - , bytestring - , bencoding - , krpc - , network - -executable bench-server - default-language: Haskell2010 - hs-source-dirs: bench - main-is: Server.hs - build-depends: base == 4.* - , bytestring - , krpc - , network - ghc-options: -fforce-recomp +--executable test-server +-- default-language: Haskell2010 +-- hs-source-dirs: tests +-- main-is: Server.hs +-- other-modules: Shared +-- build-depends: base == 4.* +-- , bytestring +-- , bencoding +-- , krpc +-- , network + +--executable bench-server +-- default-language: Haskell2010 +-- hs-source-dirs: bench +-- main-is: Server.hs +-- build-depends: base == 4.* +-- , bytestring +-- , krpc +-- , network +-- ghc-options: -fforce-recomp benchmark bench-client type: exitcode-stdio-1.0 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index f891d5a0..d295a965 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -93,45 +93,45 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FunctionalDependencies #-} module Network.KRPC - ( -- * Method - Method(..) - , method - , idM + ( KRPC (..) + + -- * Exception + , KError (..) + + -- * Method + , Method(..) -- * Client , call -- * Server , MethodHandler - , (==>) - , (==>@) + , handler , server - - -- * Internal - , call_ - , withRemote ) where -import Control.Applicative import Control.Exception import Control.Monad.Trans.Control import Control.Monad.IO.Class import Data.BEncode as BE -import Data.BEncode.BDict as BE -import Data.BEncode.Types as BE import Data.ByteString.Char8 as BC import Data.List as L import Data.Monoid +import Data.String import Data.Typeable import Network import Network.Socket -import GHC.Generics import Network.KRPC.Protocol +class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where + method :: Method req resp + -- | Method datatype used to describe name, parameters and return -- values of procedure. Client use a method to /invoke/, server -- /implements/ the method to make the actual work. @@ -147,187 +147,62 @@ import Network.KRPC.Protocol -- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments -- and return two values. -- --- To pass raw dictionaries you should specify empty param list: --- --- > method "my_method" [] [] :: Method BEncode BEncode --- --- In this case you should handle dictionary extraction by hand, both --- in client and server. --- -data Method param result = Method { - -- | Name used in query. - methodName :: MethodName - - -- | Name of each parameter in /right to left/ order. - , methodParams :: [ParamName] - - -- | Name of each return value in /right to left/ order. - , methodVals :: [ValName] - } deriving (Eq, Ord, Generic) - -instance BEncode (Method a b) +newtype Method param result = Method MethodName + deriving (Eq, Ord, IsString, BEncode) instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod -showsMethod - :: forall a. forall b. - Typeable a => Typeable b - => Method a b -> ShowS -showsMethod Method {..} = - showString (BC.unpack methodName) <> +showsMethod :: forall a. forall b. Typeable a => Typeable b + => Method a b -> ShowS +showsMethod (Method name) = + shows name <> showString " :: " <> - showsTuple methodParams paramsTy <> + shows paramsTy <> showString " -> " <> - showsTuple methodVals valuesTy - where - paramsTy = typeOf (error "KRPC.showsMethod: impossible" :: a) - valuesTy = typeOf (error "KRPC.showsMethod: impossible" :: b) - - showsTuple ns ty - = showChar '(' - <> mconcat (L.intersperse (showString ", ") $ - L.zipWith showsTyArgName ns (detuple ty)) - <> showChar ')' - - showsTyArgName ns ty - = showString (BC.unpack ns) - <> showString " :: " - <> showString (show ty) - - detuple tyRep - | L.null args = [tyRep] - | otherwise = args - where - args = typeRepArgs tyRep - - --- | Identity procedure signature. Could be used for echo --- servers. Implemented as: --- --- > idM = method "id" ["x"] ["y"] --- -idM :: Method a a -idM = method "id" ["x"] ["y"] -{-# INLINE idM #-} - --- | Makes method signature. Note that order of parameters and return --- values are not important as long as corresponding names and types --- are match. For exsample this is the equal definitions: --- --- > methodA : Method (Foo, Bar) (Baz, Quux) --- > methodA = method "mymethod" ["a", "b"] ["c", "d"] --- --- > methodA : Method (Bar, Foo) (Quux, Baz) --- > methodB = method "mymethod" ["b", "a"] ["d", "c"] --- -method :: MethodName -> [ParamName] -> [ValName] -> Method param result -method = Method -{-# INLINE method #-} - -lookupKey :: ParamName -> BDict -> Result BValue -lookupKey x = maybe (Left ("not found key " ++ BC.unpack x)) Right . BE.lookup x - -extractArgs :: [ParamName] -> BDict -> Result BValue -extractArgs [] d = Right $ if BE.null d then BList [] else BDict d -extractArgs [x] d = lookupKey x d -extractArgs xs d = BList <$> mapM (`lookupKey` d) xs -{-# INLINE extractArgs #-} - -zipBDict :: [BKey] -> [BValue] -> BDict -zipBDict (k : ks) (v : vs) = Cons k v (zipBDict ks vs) -zipBDict _ _ = Nil - -injectVals :: [ParamName] -> BValue -> BDict -injectVals [] (BList []) = BE.empty -injectVals [] (BDict d ) = d -injectVals [] be = invalidParamList [] be -injectVals [p] arg = BE.singleton p arg -injectVals ps (BList as) = zipBDict ps as -injectVals ps be = invalidParamList ps be -{-# INLINE injectVals #-} - -invalidParamList :: [ParamName] -> BValue -> a -invalidParamList pl be - = error $ "KRPC invalid parameter list: " ++ show pl ++ "\n" ++ - "while procedure args are: " ++ show be - -queryCall :: BEncode param => Socket -> SockAddr - -> Method param result -> param -> IO () -queryCall sock addr m arg = sendMessage q addr sock + shows valuesTy where - q = kquery (methodName m) (injectVals (methodParams m) (toBEncode arg)) + impossible = error "KRPC.showsMethod: impossible" + paramsTy = typeOf (impossible :: a) + valuesTy = typeOf (impossible :: b) -getResult :: BEncode result => Socket -> Method param result -> IO result -getResult sock m = do - resp <- recvResponse sock - case resp of - Left e -> throw e - Right (respVals -> dict) -> do - case fromBEncode =<< extractArgs (methodVals m) dict of - Right vals -> return vals - Left e -> throw (ProtocolError (BC.pack e)) +getResult :: BEncode result => Socket -> IO result +getResult sock = do + resp <- either throw (return . respVals) =<< recvResponse sock + either (throw . ProtocolError . BC.pack) return $ fromBEncode resp -- | Makes remote procedure call. Throws RPCException on any error -- occurred. -call :: (MonadBaseControl IO host, MonadIO host) - => (BEncode param, BEncode result) - => SockAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call addr m arg = liftIO $ withRemote $ \sock -> do call_ sock addr m arg - --- | The same as 'call' but use already opened socket. -call_ :: (MonadBaseControl IO host, MonadIO host) - => (BEncode param, BEncode result) - => Socket -- ^ Socket to use - -> SockAddr -- ^ Address of callee. - -> Method param result -- ^ Procedure to call. - -> param -- ^ Arguments passed by callee to procedure. - -> host result -- ^ Values returned by callee from the procedure. -call_ sock addr m arg = liftIO $ do - queryCall sock addr m arg - getResult sock m - +call :: forall req resp host. + (MonadBaseControl IO host, MonadIO host, KRPC req resp) + => SockAddr -> req -> host resp +call addr arg = liftIO $ withRemote $ \sock -> do + sendMessage (KQuery name (toBEncode arg)) addr sock + getResult sock + where + Method name = method :: Method req resp type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. type MethodHandler remote = (MethodName, HandlerBody remote) --- we can safely erase types in (==>) --- | Assign method implementation to the method signature. -(==>) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncode param, BEncode result) - => Monad remote - => Method param result -- ^ Signature. - -> (param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>) #-} -m ==> body = m ==>@ const body -infix 1 ==> - -- | Similar to '==>@' but additionally pass caller address. -(==>@) :: forall (remote :: * -> *) (param :: *) (result :: *). - (BEncode param, BEncode result) - => Monad remote - => Method param result -- ^ Signature. - -> (SockAddr -> param -> remote result) -- ^ Implementation. - -> MethodHandler remote -- ^ Handler used by server. -{-# INLINE (==>@) #-} -m ==>@ body = (methodName m, newbody) +handler :: forall (remote :: * -> *) (req :: *) (resp :: *). + (KRPC req resp, Monad remote) + => (SockAddr -> req -> remote resp) -> MethodHandler remote +handler body = (name, newbody) where + Method name = method :: Method req resp + {-# INLINE newbody #-} newbody addr q = - case fromBEncode =<< extractArgs (methodParams m) (queryArgs q) of + case fromBEncode (queryArgs q) of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body addr a - return (Right (kresponse (injectVals (methodVals m) (toBEncode r)))) - -infix 1 ==>@ + return (Right (KResponse (toBEncode r))) -- | Run RPC server on specified port by using list of handlers. -- Server will dispatch procedure specified by callee, but note that diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index adc02b5f..5b072d79 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -26,15 +26,13 @@ module Network.KRPC.Protocol , mkKError -- * Query - , KQuery(queryMethod, queryArgs) + , KQuery(..) , MethodName , ParamName - , kquery -- * Response - , KResponse(respVals) + , KResponse(..) , ValName - , kresponse , sendMessage , recvResponse @@ -134,16 +132,16 @@ type ParamName = ByteString -- -- > { "y" : "q", "q" : "", "a" : [, , ...] } -- -data KQuery = KQuery { - queryMethod :: !MethodName - , queryArgs :: BDict +data KQuery = KQuery + { queryMethod :: !MethodName + , queryArgs :: !BValue } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KQuery where {-# SPECIALIZE instance BEncode KQuery #-} {-# INLINE toBEncode #-} toBEncode (KQuery m args) = toDict $ - "a" .=! BDict args + "a" .=! args .: "q" .=! m .: "y" .=! ("q" :: ByteString) .: endDict @@ -157,11 +155,6 @@ instance BEncode KQuery where fromBEncode _ = decodingError "KQuery" -kquery :: MethodName -> BDict -> KQuery -kquery = KQuery -{-# INLINE kquery #-} - - type ValName = ByteString -- | KResponse used to signal that callee successufully process a @@ -173,8 +166,9 @@ type ValName = ByteString -- -- > { "y" : "r", "r" : [, , ...] } -- -newtype KResponse = KResponse { respVals :: BDict } - deriving (Show, Read, Eq, Ord, Typeable) +newtype KResponse = KResponse + { respVals :: BValue + } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KResponse where {-# INLINE toBEncode #-} @@ -190,10 +184,6 @@ instance BEncode KResponse where fromBEncode _ = decodingError "KDict" -kresponse :: BDict -> KResponse -kresponse = KResponse -{-# INLINE kresponse #-} - sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 -- cgit v1.2.3 From 621c73c849332a9446c6e5b9bcd557b30884b318 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 17:18:27 +0400 Subject: Move all socket stuff to KRPC module --- src/Network/KRPC.hs | 66 +++++++++++++++++++++++++++++++++++- src/Network/KRPC/Protocol.hs | 81 +------------------------------------------- 2 files changed, 66 insertions(+), 81 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index d295a965..802cddc5 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -114,17 +114,21 @@ module Network.KRPC , server ) where -import Control.Exception +import Control.Applicative +import Control.Exception.Lifted as Lifted +import Control.Monad import Control.Monad.Trans.Control import Control.Monad.IO.Class import Data.BEncode as BE import Data.ByteString.Char8 as BC +import Data.ByteString.Lazy as BL import Data.List as L import Data.Monoid import Data.String import Data.Typeable import Network import Network.Socket +import Network.Socket.ByteString as BS import Network.KRPC.Protocol @@ -166,6 +170,32 @@ showsMethod (Method name) = paramsTy = typeOf (impossible :: a) valuesTy = typeOf (impossible :: b) +{----------------------------------------------------------------------- +-- Client +-----------------------------------------------------------------------} + +sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () +sendMessage msg addr sock = sendManyTo sock (BL.toChunks (encode msg)) addr +{-# INLINE sendMessage #-} + +maxMsgSize :: Int +--maxMsgSize = 512 -- release: size of payload of one udp packet +maxMsgSize = 64 * 1024 -- bench: max UDP MTU +{-# INLINE maxMsgSize #-} + +recvResponse :: Socket -> IO (Either KError KResponse) +recvResponse sock = do + (raw, _) <- BS.recvFrom sock maxMsgSize + return $ case decode raw of + Right resp -> Right resp + Left decE -> Left $ case decode raw of + Right kerror -> kerror + _ -> ProtocolError (BC.pack decE) + +withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a +withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) + (liftIO . sClose) +{-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} getResult :: BEncode result => Socket -> IO result getResult sock = do @@ -183,6 +213,10 @@ call addr arg = liftIO $ withRemote $ \sock -> do where Method name = method :: Method req resp +{----------------------------------------------------------------------- +-- Server +-----------------------------------------------------------------------} + type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) -- | Procedure signature and implementation binded up. @@ -204,6 +238,36 @@ handler body = (name, newbody) r <- body addr a return (Right (KResponse (toBEncode r))) +sockAddrFamily :: SockAddr -> Family +sockAddrFamily (SockAddrInet _ _ ) = AF_INET +sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +sockAddrFamily (SockAddrUnix _ ) = AF_UNIX + +-- | Run server using a given port. Method invocation should be done manually. +remoteServer :: (MonadBaseControl IO remote, MonadIO remote) + => SockAddr -- ^ Port number to listen. + -> (SockAddr -> KQuery -> remote (Either KError KResponse)) + -> remote () +remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop + where + bindServ = do + let family = sockAddrFamily servAddr + sock <- socket family Datagram defaultProtocol + when (family == AF_INET6) $ do + setSocketOption sock IPv6Only 0 + bindSocket sock servAddr + return sock + + loop sock = forever $ do + (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize + reply <- handleMsg bs addr + liftIO $ sendMessage reply addr sock + where + handleMsg bs addr = case decode bs of + Right query -> (either toBEncode toBEncode <$> action addr query) + `Lifted.catch` (return . toBEncode . serverError) + Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) + -- | Run RPC server on specified port by using list of handlers. -- Server will dispatch procedure specified by callee, but note that -- it will not create new thread for each connection. diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs index 5b072d79..55bbdf4e 100644 --- a/src/Network/KRPC/Protocol.hs +++ b/src/Network/KRPC/Protocol.hs @@ -21,45 +21,23 @@ module Network.KRPC.Protocol ( -- * Error KError(..) - , ErrorCode - , errorCode - , mkKError + , serverError -- * Query , KQuery(..) , MethodName - , ParamName -- * Response , KResponse(..) - , ValName - - , sendMessage - , recvResponse - - -- * Remote - , withRemote - , remoteServer ) where -import Control.Applicative import Control.Exception.Lifted as Lifted -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Control - import Data.BEncode as BE import Data.BEncode.BDict as BE -import Data.BEncode.Types as BE import Data.ByteString as B import Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB import Data.Typeable -import Network.Socket hiding (recvFrom) -import Network.Socket.ByteString - - -- | Errors used to signal that some error occurred while processing a -- procedure call. Error may be send only from server to client but -- not in the opposite direction. @@ -120,9 +98,7 @@ mkKError _ = GenericError serverError :: SomeException -> KError serverError = ServerError . BC.pack . show - type MethodName = ByteString -type ParamName = ByteString -- | Query used to signal that caller want to make procedure call to -- callee and pass arguments in. Therefore query may be only sent from @@ -155,8 +131,6 @@ instance BEncode KQuery where fromBEncode _ = decodingError "KQuery" -type ValName = ByteString - -- | KResponse used to signal that callee successufully process a -- procedure call and to return values from procedure. KResponse should -- not be sent if error occurred during RPC. Thus KResponse may be only @@ -183,56 +157,3 @@ instance BEncode KResponse where KResponse <$>! "r" fromBEncode _ = decodingError "KDict" - -sockAddrFamily :: SockAddr -> Family -sockAddrFamily (SockAddrInet _ _ ) = AF_INET -sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 -sockAddrFamily (SockAddrUnix _ ) = AF_UNIX - -withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) - (liftIO . sClose) -{-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} - -maxMsgSize :: Int ---maxMsgSize = 512 -- release: size of payload of one udp packet -maxMsgSize = 64 * 1024 -- bench: max UDP MTU -{-# INLINE maxMsgSize #-} - -sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () -sendMessage msg addr sock = sendManyTo sock (LB.toChunks (encode msg)) addr -{-# INLINE sendMessage #-} - -recvResponse :: Socket -> IO (Either KError KResponse) -recvResponse sock = do - (raw, _) <- recvFrom sock maxMsgSize - return $ case decode raw of - Right resp -> Right resp - Left decE -> Left $ case decode raw of - Right kerror -> kerror - _ -> ProtocolError (BC.pack decE) - --- | Run server using a given port. Method invocation should be done manually. -remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => SockAddr -- ^ Port number to listen. - -> (SockAddr -> KQuery -> remote (Either KError KResponse)) - -> remote () -remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop - where - bindServ = do - let family = sockAddrFamily servAddr - sock <- socket family Datagram defaultProtocol - when (family == AF_INET6) $ do - setSocketOption sock IPv6Only 0 - bindSocket sock servAddr - return sock - - loop sock = forever $ do - (bs, addr) <- liftIO $ recvFrom sock maxMsgSize - reply <- handleMsg bs addr - liftIO $ sendMessage reply addr sock - where - handleMsg bs addr = case decode bs of - Right query -> (either toBEncode toBEncode <$> action addr query) - `Lifted.catch` (return . toBEncode . serverError) - Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) -- cgit v1.2.3 From 7a13eea1ad815411ee7bce4dcaa8a49bdd979356 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 17:20:16 +0400 Subject: Rename Protocol module to Message --- krpc.cabal | 2 +- src/Network/KRPC.hs | 2 +- src/Network/KRPC/Message.hs | 159 +++++++++++++++++++++++++++++++++++++++++++ src/Network/KRPC/Protocol.hs | 159 ------------------------------------------- 4 files changed, 161 insertions(+), 161 deletions(-) create mode 100644 src/Network/KRPC/Message.hs delete mode 100644 src/Network/KRPC/Protocol.hs diff --git a/krpc.cabal b/krpc.cabal index 28c2eaae..46968874 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -37,7 +37,7 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Network.KRPC - , Network.KRPC.Protocol + , Network.KRPC.Message build-depends: base == 4.* , bytestring >= 0.10 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 802cddc5..8e158f48 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -130,7 +130,7 @@ import Network import Network.Socket import Network.Socket.ByteString as BS -import Network.KRPC.Protocol +import Network.KRPC.Message class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs new file mode 100644 index 00000000..854b733c --- /dev/null +++ b/src/Network/KRPC/Message.hs @@ -0,0 +1,159 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This module provides straightforward implementation of KRPC +-- protocol. In many situations 'Network.KRPC' should be prefered +-- since it gives more safe, convenient and high level api. +-- +-- See +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Network.KRPC.Message + ( -- * Error + KError(..) + , serverError + + -- * Query + , KQuery(..) + , MethodName + + -- * Response + , KResponse(..) + ) where + +import Control.Exception.Lifted as Lifted +import Data.BEncode as BE +import Data.BEncode.BDict as BE +import Data.ByteString as B +import Data.ByteString.Char8 as BC +import Data.Typeable + +-- | Errors used to signal that some error occurred while processing a +-- procedure call. Error may be send only from server to client but +-- not in the opposite direction. +-- +-- Errors are encoded as bencoded dictionary: +-- +-- > { "y" : "e", "e" : [, ] } +-- +data KError + -- | Some error doesn't fit in any other category. + = GenericError { errorMessage :: !ByteString } + + -- | Occur when server fail to process procedure call. + | ServerError { errorMessage :: !ByteString } + + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError { errorMessage :: !ByteString } + + -- | Occur when client trying to call method server don't know. + | MethodUnknown { errorMessage :: !ByteString } + deriving (Show, Read, Eq, Ord, Typeable) + +instance BEncode KError where + {-# SPECIALIZE instance BEncode KError #-} + {-# INLINE toBEncode #-} + toBEncode e = toDict $ + "e" .=! (errorCode e, errorMessage e) + .: "y" .=! ("e" :: ByteString) + .: endDict + + {-# INLINE fromBEncode #-} + fromBEncode be @ (BDict d) + | BE.lookup "y" d == Just (BString "e") + = (`fromDict` be) $ do + uncurry mkKError <$>! "e" + + fromBEncode _ = decodingError "KError" + +instance Exception KError + +type ErrorCode = Int + +errorCode :: KError -> ErrorCode +errorCode (GenericError _) = 201 +errorCode (ServerError _) = 202 +errorCode (ProtocolError _) = 203 +errorCode (MethodUnknown _) = 204 +{-# INLINE errorCode #-} + +mkKError :: ErrorCode -> ByteString -> KError +mkKError 201 = GenericError +mkKError 202 = ServerError +mkKError 203 = ProtocolError +mkKError 204 = MethodUnknown +mkKError _ = GenericError +{-# INLINE mkKError #-} + +serverError :: SomeException -> KError +serverError = ServerError . BC.pack . show + +type MethodName = ByteString + +-- | Query used to signal that caller want to make procedure call to +-- callee and pass arguments in. Therefore query may be only sent from +-- client to server but not in the opposite direction. +-- +-- Queries are encoded as bencoded dictionary: +-- +-- > { "y" : "q", "q" : "", "a" : [, , ...] } +-- +data KQuery = KQuery + { queryMethod :: !MethodName + , queryArgs :: !BValue + } deriving (Show, Read, Eq, Ord, Typeable) + +instance BEncode KQuery where + {-# SPECIALIZE instance BEncode KQuery #-} + {-# INLINE toBEncode #-} + toBEncode (KQuery m args) = toDict $ + "a" .=! args + .: "q" .=! m + .: "y" .=! ("q" :: ByteString) + .: endDict + + {-# INLINE fromBEncode #-} + fromBEncode bv @ (BDict d) + | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do + a <- field (req "a") + q <- field (req "q") + return $! KQuery q a + + fromBEncode _ = decodingError "KQuery" + +-- | KResponse used to signal that callee successufully process a +-- procedure call and to return values from procedure. KResponse should +-- not be sent if error occurred during RPC. Thus KResponse may be only +-- sent from server to client. +-- +-- Responses are encoded as bencoded dictionary: +-- +-- > { "y" : "r", "r" : [, , ...] } +-- +newtype KResponse = KResponse + { respVals :: BValue + } deriving (Show, Read, Eq, Ord, Typeable) + +instance BEncode KResponse where + {-# INLINE toBEncode #-} + toBEncode (KResponse vals) = toDict $ + "r" .=! vals + .: "y" .=! ("r" :: ByteString) + .: endDict + + {-# INLINE fromBEncode #-} + fromBEncode bv @ (BDict d) + | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do + KResponse <$>! "r" + + fromBEncode _ = decodingError "KDict" diff --git a/src/Network/KRPC/Protocol.hs b/src/Network/KRPC/Protocol.hs deleted file mode 100644 index 55bbdf4e..00000000 --- a/src/Network/KRPC/Protocol.hs +++ /dev/null @@ -1,159 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- This module provides straightforward implementation of KRPC --- protocol. In many situations 'Network.KRPC' should be prefered --- since it gives more safe, convenient and high level api. --- --- See --- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Network.KRPC.Protocol - ( -- * Error - KError(..) - , serverError - - -- * Query - , KQuery(..) - , MethodName - - -- * Response - , KResponse(..) - ) where - -import Control.Exception.Lifted as Lifted -import Data.BEncode as BE -import Data.BEncode.BDict as BE -import Data.ByteString as B -import Data.ByteString.Char8 as BC -import Data.Typeable - --- | Errors used to signal that some error occurred while processing a --- procedure call. Error may be send only from server to client but --- not in the opposite direction. --- --- Errors are encoded as bencoded dictionary: --- --- > { "y" : "e", "e" : [, ] } --- -data KError - -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: !ByteString } - - -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: !ByteString } - - -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: !ByteString } - - -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: !ByteString } - deriving (Show, Read, Eq, Ord, Typeable) - -instance BEncode KError where - {-# SPECIALIZE instance BEncode KError #-} - {-# INLINE toBEncode #-} - toBEncode e = toDict $ - "e" .=! (errorCode e, errorMessage e) - .: "y" .=! ("e" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode be @ (BDict d) - | BE.lookup "y" d == Just (BString "e") - = (`fromDict` be) $ do - uncurry mkKError <$>! "e" - - fromBEncode _ = decodingError "KError" - -instance Exception KError - -type ErrorCode = Int - -errorCode :: KError -> ErrorCode -errorCode (GenericError _) = 201 -errorCode (ServerError _) = 202 -errorCode (ProtocolError _) = 203 -errorCode (MethodUnknown _) = 204 -{-# INLINE errorCode #-} - -mkKError :: ErrorCode -> ByteString -> KError -mkKError 201 = GenericError -mkKError 202 = ServerError -mkKError 203 = ProtocolError -mkKError 204 = MethodUnknown -mkKError _ = GenericError -{-# INLINE mkKError #-} - -serverError :: SomeException -> KError -serverError = ServerError . BC.pack . show - -type MethodName = ByteString - --- | Query used to signal that caller want to make procedure call to --- callee and pass arguments in. Therefore query may be only sent from --- client to server but not in the opposite direction. --- --- Queries are encoded as bencoded dictionary: --- --- > { "y" : "q", "q" : "", "a" : [, , ...] } --- -data KQuery = KQuery - { queryMethod :: !MethodName - , queryArgs :: !BValue - } deriving (Show, Read, Eq, Ord, Typeable) - -instance BEncode KQuery where - {-# SPECIALIZE instance BEncode KQuery #-} - {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = toDict $ - "a" .=! args - .: "q" .=! m - .: "y" .=! ("q" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do - a <- field (req "a") - q <- field (req "q") - return $! KQuery q a - - fromBEncode _ = decodingError "KQuery" - --- | KResponse used to signal that callee successufully process a --- procedure call and to return values from procedure. KResponse should --- not be sent if error occurred during RPC. Thus KResponse may be only --- sent from server to client. --- --- Responses are encoded as bencoded dictionary: --- --- > { "y" : "r", "r" : [, , ...] } --- -newtype KResponse = KResponse - { respVals :: BValue - } deriving (Show, Read, Eq, Ord, Typeable) - -instance BEncode KResponse where - {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = toDict $ - "r" .=! vals - .: "y" .=! ("r" :: ByteString) - .: endDict - - {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do - KResponse <$>! "r" - - fromBEncode _ = decodingError "KDict" -- cgit v1.2.3 From 1a8e7be91a81e97c4fbf35758a35973a04cdbcdc Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 18:44:22 +0400 Subject: Add TransactionId to KQuery and KResponse --- krpc.cabal | 5 +---- src/Network/KRPC.hs | 8 ++++---- src/Network/KRPC/Message.hs | 47 ++++++++++++++++++++++----------------------- 3 files changed, 28 insertions(+), 32 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index 46968874..aa081a54 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -40,13 +40,10 @@ library , Network.KRPC.Message build-depends: base == 4.* , bytestring >= 0.10 - , lifted-base >= 0.1.1 , transformers >= 0.2 , monad-control >= 0.3 - - , bencoding == 0.4.* - + , bencoding >= 0.4.3 , network >= 2.3 if impl(ghc < 7.6) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 8e158f48..2c3a1b48 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -208,7 +208,7 @@ call :: forall req resp host. (MonadBaseControl IO host, MonadIO host, KRPC req resp) => SockAddr -> req -> host resp call addr arg = liftIO $ withRemote $ \sock -> do - sendMessage (KQuery name (toBEncode arg)) addr sock + sendMessage (KQuery (toBEncode arg) name undefined) addr sock getResult sock where Method name = method :: Method req resp @@ -231,12 +231,12 @@ handler body = (name, newbody) Method name = method :: Method req resp {-# INLINE newbody #-} - newbody addr q = - case fromBEncode (queryArgs q) of + newbody addr KQuery {..} = + case fromBEncode queryArgs of Left e -> return (Left (ProtocolError (BC.pack e))) Right a -> do r <- body addr a - return (Right (KResponse (toBEncode r))) + return (Right (KResponse (toBEncode r) queryId)) sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 854b733c..1a004c64 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -100,6 +100,8 @@ serverError = ServerError . BC.pack . show type MethodName = ByteString +type TransactionId = ByteString + -- | Query used to signal that caller want to make procedure call to -- callee and pass arguments in. Therefore query may be only sent from -- client to server but not in the opposite direction. @@ -109,27 +111,24 @@ type MethodName = ByteString -- > { "y" : "q", "q" : "", "a" : [, , ...] } -- data KQuery = KQuery - { queryMethod :: !MethodName - , queryArgs :: !BValue + { queryArgs :: !BValue + , queryMethod :: !MethodName + , queryId :: !TransactionId } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KQuery where - {-# SPECIALIZE instance BEncode KQuery #-} - {-# INLINE toBEncode #-} - toBEncode (KQuery m args) = toDict $ - "a" .=! args - .: "q" .=! m + toBEncode KQuery {..} = toDict $ + "a" .=! queryArgs + .: "q" .=! queryMethod + .: "t" .=! queryId .: "y" .=! ("q" :: ByteString) .: endDict + {-# INLINE toBEncode #-} + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "q") + KQuery <$>! "a" <*>! "q" <*>! "t" {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "q") = (`fromDict` bv) $ do - a <- field (req "a") - q <- field (req "q") - return $! KQuery q a - - fromBEncode _ = decodingError "KQuery" -- | KResponse used to signal that callee successufully process a -- procedure call and to return values from procedure. KResponse should @@ -140,20 +139,20 @@ instance BEncode KQuery where -- -- > { "y" : "r", "r" : [, , ...] } -- -newtype KResponse = KResponse +data KResponse = KResponse { respVals :: BValue + , respId :: TransactionId } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KResponse where - {-# INLINE toBEncode #-} - toBEncode (KResponse vals) = toDict $ - "r" .=! vals + toBEncode KResponse {..} = toDict $ + "r" .=! respVals + .: "t" .=! respId .: "y" .=! ("r" :: ByteString) .: endDict + {-# INLINE toBEncode #-} - {-# INLINE fromBEncode #-} - fromBEncode bv @ (BDict d) - | BE.lookup "y" d == Just (BString "r") = (`fromDict` bv) $ do - KResponse <$>! "r" - - fromBEncode _ = decodingError "KDict" + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "r") + KResponse <$>! "r" <*>! "t" + {-# INLINE fromBEncode #-} \ No newline at end of file -- cgit v1.2.3 From 8cae1905ed3c71702569bfb191f8bf6bae772821 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 19 Dec 2013 19:05:09 +0400 Subject: Add transaction Id to error messages --- src/Network/KRPC.hs | 25 +++++----- src/Network/KRPC/Message.hs | 118 +++++++++++++++++++++++++++----------------- 2 files changed, 87 insertions(+), 56 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 2c3a1b48..a96d8da9 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -190,7 +190,7 @@ recvResponse sock = do Right resp -> Right resp Left decE -> Left $ case decode raw of Right kerror -> kerror - _ -> ProtocolError (BC.pack decE) + _ -> KError ProtocolError (BC.pack decE) undefined withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) @@ -199,8 +199,10 @@ withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) getResult :: BEncode result => Socket -> IO result getResult sock = do - resp <- either throw (return . respVals) =<< recvResponse sock - either (throw . ProtocolError . BC.pack) return $ fromBEncode resp + KResponse {..} <- either throw return =<< recvResponse sock + case fromBEncode respVals of + Left msg -> throw $ KError ProtocolError (BC.pack msg) respId + Right r -> return r -- | Makes remote procedure call. Throws RPCException on any error -- occurred. @@ -233,10 +235,10 @@ handler body = (name, newbody) {-# INLINE newbody #-} newbody addr KQuery {..} = case fromBEncode queryArgs of - Left e -> return (Left (ProtocolError (BC.pack e))) + Left e -> return $ Left $ KError ProtocolError (BC.pack e) queryId Right a -> do r <- body addr a - return (Right (KResponse (toBEncode r) queryId)) + return $ Right $ KResponse (toBEncode r) queryId sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET @@ -265,8 +267,9 @@ remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop where handleMsg bs addr = case decode bs of Right query -> (either toBEncode toBEncode <$> action addr query) - `Lifted.catch` (return . toBEncode . serverError) - Left decodeE -> return $ toBEncode (ProtocolError (BC.pack decodeE)) + `Lifted.catch` (return . toBEncode . (`serverError` undefined )) + Left decodeE -> return $ toBEncode $ + KError ProtocolError (BC.pack decodeE) undefined -- | Run RPC server on specified port by using list of handlers. -- Server will dispatch procedure specified by callee, but note that @@ -277,7 +280,7 @@ server :: (MonadBaseControl IO remote, MonadIO remote) -> [MethodHandler remote] -- ^ Method table. -> remote () server servAddr handlers = do - remoteServer servAddr $ \addr q -> do - case L.lookup (queryMethod q) handlers of - Nothing -> return $ Left $ MethodUnknown (queryMethod q) - Just m -> m addr q + remoteServer servAddr $ \addr q @ KQuery {..} -> do + case L.lookup queryMethod handlers of + Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId + Just m -> m addr q diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 1a004c64..a70c2ea9 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -20,7 +20,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module Network.KRPC.Message ( -- * Error - KError(..) + ErrorCode (..) + , KError(..) , serverError -- * Query @@ -31,13 +32,60 @@ module Network.KRPC.Message , KResponse(..) ) where +import Control.Applicative import Control.Exception.Lifted as Lifted import Data.BEncode as BE -import Data.BEncode.BDict as BE import Data.ByteString as B import Data.ByteString.Char8 as BC import Data.Typeable + +-- | This transaction ID is generated by the querying node and is +-- echoed in the response, so responses may be correlated with +-- multiple queries to the same node. The transaction ID should be +-- encoded as a short string of binary numbers, typically 2 characters +-- are enough as they cover 2^16 outstanding queries. +type TransactionId = ByteString + +{----------------------------------------------------------------------- +-- Error messages +-----------------------------------------------------------------------} + +data ErrorCode + -- | Some error doesn't fit in any other category. + = GenericError + + -- | Occur when server fail to process procedure call. + | ServerError + + -- | Malformed packet, invalid arguments or bad token. + | ProtocolError + + -- | Occur when client trying to call method server don't know. + | MethodUnknown + deriving (Show, Read, Eq, Ord, Bounded, Typeable) + +instance Enum ErrorCode where + fromEnum GenericError = 201 + fromEnum ServerError = 202 + fromEnum ProtocolError = 203 + fromEnum MethodUnknown = 204 + {-# INLINE fromEnum #-} + + toEnum 201 = GenericError + toEnum 202 = ServerError + toEnum 203 = ProtocolError + toEnum 204 = MethodUnknown + toEnum _ = GenericError + {-# INLINE toEnum #-} + +instance BEncode ErrorCode where + toBEncode = toBEncode . fromEnum + {-# INLINE toBEncode #-} + + fromBEncode b = toEnum <$> fromBEncode b + {-# INLINE fromBEncode #-} + -- | Errors used to signal that some error occurred while processing a -- procedure call. Error may be send only from server to client but -- not in the opposite direction. @@ -46,62 +94,38 @@ import Data.Typeable -- -- > { "y" : "e", "e" : [, ] } -- -data KError - -- | Some error doesn't fit in any other category. - = GenericError { errorMessage :: !ByteString } - - -- | Occur when server fail to process procedure call. - | ServerError { errorMessage :: !ByteString } - - -- | Malformed packet, invalid arguments or bad token. - | ProtocolError { errorMessage :: !ByteString } - - -- | Occur when client trying to call method server don't know. - | MethodUnknown { errorMessage :: !ByteString } - deriving (Show, Read, Eq, Ord, Typeable) +data KError = KError + { errorCode :: !ErrorCode + , errorMessage :: !ByteString + , errorId :: !TransactionId + } deriving (Show, Read, Eq, Ord, Typeable) instance BEncode KError where - {-# SPECIALIZE instance BEncode KError #-} - {-# INLINE toBEncode #-} - toBEncode e = toDict $ - "e" .=! (errorCode e, errorMessage e) + + toBEncode KError {..} = toDict $ + "e" .=! (errorCode, errorMessage) + .: "t" .=! errorId .: "y" .=! ("e" :: ByteString) .: endDict + {-# INLINE toBEncode #-} + fromBEncode = fromDict $ do + lookAhead $ match "y" (BString "e") + (code, msg) <- field (req "e") + KError code msg <$>! "t" {-# INLINE fromBEncode #-} - fromBEncode be @ (BDict d) - | BE.lookup "y" d == Just (BString "e") - = (`fromDict` be) $ do - uncurry mkKError <$>! "e" - - fromBEncode _ = decodingError "KError" instance Exception KError -type ErrorCode = Int - -errorCode :: KError -> ErrorCode -errorCode (GenericError _) = 201 -errorCode (ServerError _) = 202 -errorCode (ProtocolError _) = 203 -errorCode (MethodUnknown _) = 204 -{-# INLINE errorCode #-} +serverError :: SomeException -> TransactionId -> KError +serverError e = KError ServerError (BC.pack (show e)) -mkKError :: ErrorCode -> ByteString -> KError -mkKError 201 = GenericError -mkKError 202 = ServerError -mkKError 203 = ProtocolError -mkKError 204 = MethodUnknown -mkKError _ = GenericError -{-# INLINE mkKError #-} - -serverError :: SomeException -> KError -serverError = ServerError . BC.pack . show +{----------------------------------------------------------------------- +-- Query messages +-----------------------------------------------------------------------} type MethodName = ByteString -type TransactionId = ByteString - -- | Query used to signal that caller want to make procedure call to -- callee and pass arguments in. Therefore query may be only sent from -- client to server but not in the opposite direction. @@ -130,6 +154,10 @@ instance BEncode KQuery where KQuery <$>! "a" <*>! "q" <*>! "t" {-# INLINE fromBEncode #-} +{----------------------------------------------------------------------- +-- Response messages +-----------------------------------------------------------------------} + -- | KResponse used to signal that callee successufully process a -- procedure call and to return values from procedure. KResponse should -- not be sent if error occurred during RPC. Thus KResponse may be only -- cgit v1.2.3 From 53d384bd0028cbb54053e11b49fe0673257b7c45 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 20 Dec 2013 00:03:39 +0400 Subject: Handle transactions properly --- krpc.cabal | 6 +- src/Network/KRPC.hs | 195 ++++---------------------------------------- src/Network/KRPC/Manager.hs | 179 ++++++++++++++++++++++++++++++++++++++++ src/Network/KRPC/Message.hs | 47 ++++++++++- src/Network/KRPC/Method.hs | 61 ++++++++++++++ 5 files changed, 303 insertions(+), 185 deletions(-) create mode 100644 src/Network/KRPC/Manager.hs create mode 100644 src/Network/KRPC/Method.hs diff --git a/krpc.cabal b/krpc.cabal index aa081a54..bccdd6c3 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -37,7 +37,10 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Network.KRPC - , Network.KRPC.Message + Network.KRPC.Message + Network.KRPC.Method + Network.KRPC.Manager + build-depends: base == 4.* , bytestring >= 0.10 , lifted-base >= 0.1.1 @@ -45,6 +48,7 @@ library , monad-control >= 0.3 , bencoding >= 0.4.3 , network >= 2.3 + , containers if impl(ghc < 7.6) build-depends: ghc-prim diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index a96d8da9..09d1c5b2 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -97,190 +97,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FunctionalDependencies #-} module Network.KRPC - ( KRPC (..) + ( -- * Methods + Method + , KRPC (..) - -- * Exception - , KError (..) - - -- * Method - , Method(..) + -- * RPC + , handler + , query - -- * Client - , call + -- * Manager + , MonadKRPC (..) + , newManager +-- , closeManager - -- * Server - , MethodHandler - , handler - , server + -- * Exceptions + , KError (..) ) where -import Control.Applicative -import Control.Exception.Lifted as Lifted -import Control.Monad -import Control.Monad.Trans.Control -import Control.Monad.IO.Class -import Data.BEncode as BE -import Data.ByteString.Char8 as BC -import Data.ByteString.Lazy as BL -import Data.List as L -import Data.Monoid -import Data.String -import Data.Typeable -import Network -import Network.Socket -import Network.Socket.ByteString as BS - import Network.KRPC.Message - - -class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where - method :: Method req resp - --- | Method datatype used to describe name, parameters and return --- values of procedure. Client use a method to /invoke/, server --- /implements/ the method to make the actual work. --- --- We use the following fantom types to ensure type-safiety: --- --- * param: Type of method parameters. Ordinary Tuple type used --- to specify more than one parameter, so for example @Method --- (Int, Int) result@ will take two arguments. --- --- * result: Type of return value of the method. Similarly, --- tuple used to specify more than one return value, so for --- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments --- and return two values. --- -newtype Method param result = Method MethodName - deriving (Eq, Ord, IsString, BEncode) - -instance (Typeable a, Typeable b) => Show (Method a b) where - showsPrec _ = showsMethod - -showsMethod :: forall a. forall b. Typeable a => Typeable b - => Method a b -> ShowS -showsMethod (Method name) = - shows name <> - showString " :: " <> - shows paramsTy <> - showString " -> " <> - shows valuesTy - where - impossible = error "KRPC.showsMethod: impossible" - paramsTy = typeOf (impossible :: a) - valuesTy = typeOf (impossible :: b) - -{----------------------------------------------------------------------- --- Client ------------------------------------------------------------------------} - -sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () -sendMessage msg addr sock = sendManyTo sock (BL.toChunks (encode msg)) addr -{-# INLINE sendMessage #-} - -maxMsgSize :: Int ---maxMsgSize = 512 -- release: size of payload of one udp packet -maxMsgSize = 64 * 1024 -- bench: max UDP MTU -{-# INLINE maxMsgSize #-} - -recvResponse :: Socket -> IO (Either KError KResponse) -recvResponse sock = do - (raw, _) <- BS.recvFrom sock maxMsgSize - return $ case decode raw of - Right resp -> Right resp - Left decE -> Left $ case decode raw of - Right kerror -> kerror - _ -> KError ProtocolError (BC.pack decE) undefined - -withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a -withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) - (liftIO . sClose) -{-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} - -getResult :: BEncode result => Socket -> IO result -getResult sock = do - KResponse {..} <- either throw return =<< recvResponse sock - case fromBEncode respVals of - Left msg -> throw $ KError ProtocolError (BC.pack msg) respId - Right r -> return r - --- | Makes remote procedure call. Throws RPCException on any error --- occurred. -call :: forall req resp host. - (MonadBaseControl IO host, MonadIO host, KRPC req resp) - => SockAddr -> req -> host resp -call addr arg = liftIO $ withRemote $ \sock -> do - sendMessage (KQuery (toBEncode arg) name undefined) addr sock - getResult sock - where - Method name = method :: Method req resp - -{----------------------------------------------------------------------- --- Server ------------------------------------------------------------------------} - -type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) - --- | Procedure signature and implementation binded up. -type MethodHandler remote = (MethodName, HandlerBody remote) - --- | Similar to '==>@' but additionally pass caller address. -handler :: forall (remote :: * -> *) (req :: *) (resp :: *). - (KRPC req resp, Monad remote) - => (SockAddr -> req -> remote resp) -> MethodHandler remote -handler body = (name, newbody) - where - Method name = method :: Method req resp - - {-# INLINE newbody #-} - newbody addr KQuery {..} = - case fromBEncode queryArgs of - Left e -> return $ Left $ KError ProtocolError (BC.pack e) queryId - Right a -> do - r <- body addr a - return $ Right $ KResponse (toBEncode r) queryId - -sockAddrFamily :: SockAddr -> Family -sockAddrFamily (SockAddrInet _ _ ) = AF_INET -sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 -sockAddrFamily (SockAddrUnix _ ) = AF_UNIX - --- | Run server using a given port. Method invocation should be done manually. -remoteServer :: (MonadBaseControl IO remote, MonadIO remote) - => SockAddr -- ^ Port number to listen. - -> (SockAddr -> KQuery -> remote (Either KError KResponse)) - -> remote () -remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop - where - bindServ = do - let family = sockAddrFamily servAddr - sock <- socket family Datagram defaultProtocol - when (family == AF_INET6) $ do - setSocketOption sock IPv6Only 0 - bindSocket sock servAddr - return sock - - loop sock = forever $ do - (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize - reply <- handleMsg bs addr - liftIO $ sendMessage reply addr sock - where - handleMsg bs addr = case decode bs of - Right query -> (either toBEncode toBEncode <$> action addr query) - `Lifted.catch` (return . toBEncode . (`serverError` undefined )) - Left decodeE -> return $ toBEncode $ - KError ProtocolError (BC.pack decodeE) undefined - --- | Run RPC server on specified port by using list of handlers. --- Server will dispatch procedure specified by callee, but note that --- it will not create new thread for each connection. --- -server :: (MonadBaseControl IO remote, MonadIO remote) - => SockAddr -- ^ Port used to accept incoming connections. - -> [MethodHandler remote] -- ^ Method table. - -> remote () -server servAddr handlers = do - remoteServer servAddr $ \addr q @ KQuery {..} -> do - case L.lookup queryMethod handlers of - Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId - Just m -> m addr q +import Network.KRPC.Method +import Network.KRPC.Manager \ No newline at end of file diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs new file mode 100644 index 00000000..9aa1bea7 --- /dev/null +++ b/src/Network/KRPC/Manager.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.KRPC.Manager + ( MonadKRPC (..) + , newManager + , query + , handler + ) where + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +--import Control.Exception hiding (Handler) +import Control.Exception.Lifted as Lifted hiding (Handler) +import Control.Monad +import Control.Monad.Trans.Control +import Control.Monad.IO.Class +import Data.BEncode as BE +import Data.ByteString.Char8 as BC +import Data.ByteString.Lazy as BL +import Data.IORef +import Data.List as L +import Data.Map as M +import Network.KRPC.Message +import Network.KRPC.Method +import Network.Socket +import Network.Socket.ByteString as BS + + +type KResult = Either KError KResponse + +type TransactionCounter = IORef Int +type CallId = (TransactionId, SockAddr) +type CallRes = MVar KResult +type PendingCalls = IORef (Map CallId CallRes) + +type HandlerBody m = SockAddr -> BValue -> m (BE.Result BValue) +type Handler m = (MethodName, HandlerBody m) + +data Manager m = Manager + { sock :: !Socket + , transactionCounter :: {-# UNPACK #-} !TransactionCounter + , pendingCalls :: {-# UNPACK #-} !PendingCalls + , handlers :: [Handler m] + } + +class (MonadBaseControl IO m, MonadIO m) => MonadKRPC m where + getManager :: m (Manager a) + +sockAddrFamily :: SockAddr -> Family +sockAddrFamily (SockAddrInet _ _ ) = AF_INET +sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 +sockAddrFamily (SockAddrUnix _ ) = AF_UNIX + +seedTransaction :: Int +seedTransaction = 0 + +newManager :: SockAddr -> IO (Manager a) +newManager servAddr = do + sock <- bindServ + tran <- newIORef seedTransaction + calls <- newIORef M.empty + return $ Manager sock tran calls [] + where + bindServ = do + let family = sockAddrFamily servAddr + sock <- socket family Datagram defaultProtocol + when (family == AF_INET6) $ do + setSocketOption sock IPv6Only 0 + bindSocket sock servAddr + return sock + +sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () +sendMessage sock addr a = + liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr + +{----------------------------------------------------------------------- +-- Client +-----------------------------------------------------------------------} + +genTransactionId :: TransactionCounter -> IO TransactionId +genTransactionId ref = do + cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur) + return $ BC.pack (show cur) + +registerQuery :: CallId -> PendingCalls -> IO CallRes +registerQuery cid ref = do + ares <- newEmptyMVar + atomicModifyIORef' ref $ \ m -> (M.insert cid ares m, ()) + return ares + +unregisterQuery :: CallId -> PendingCalls -> IO () +unregisterQuery cid ref = do + atomicModifyIORef' ref $ \ m -> (M.delete cid m, ()) + +queryResponse :: BEncode a => CallRes -> IO a +queryResponse ares = do + res <- readMVar ares + case res of + Left e -> throwIO e + Right (KResponse {..}) -> + case fromBEncode respVals of + Left e -> throwIO (KError ProtocolError (BC.pack e) respId) + Right a -> return a + +query :: forall m a b. (MonadKRPC m, KRPC a b) => SockAddr -> a -> m b +query addr params = do + Manager {..} <- getManager + liftIO $ do + tid <- genTransactionId transactionCounter + let Method name = method :: Method a b + let q = KQuery (toBEncode params) name tid + ares <- registerQuery (tid, addr) pendingCalls + sendMessage sock addr q + `onException` unregisterQuery (tid, addr) pendingCalls + queryResponse ares + +{----------------------------------------------------------------------- +-- Handlers +-----------------------------------------------------------------------} + +handler :: forall m a b. (KRPC a b, MonadKRPC m) + => (SockAddr -> a -> m b) -> Handler m +handler body = (name, wrapper) + where + Method name = method :: Method a b + wrapper addr args = + case fromBEncode args of + Left e -> return $ Left e + Right a -> (Right . toBEncode) <$> body addr a + +runHandler :: MonadKRPC m => HandlerBody m -> SockAddr -> KQuery -> m KResult +runHandler handler addr KQuery {..} = wrapper `Lifted.catch` failback + where + wrapper = ((`decodeError` queryId) +++ (`KResponse` queryId)) + <$> handler addr queryArgs + failback e = return $ Left $ serverError e queryId + +dispatchHandler :: MonadKRPC m => KQuery -> SockAddr -> m KResult +dispatchHandler q @ KQuery {..} addr = do + Manager {..} <- getManager + case L.lookup queryMethod handlers of + Nothing -> return $ Left $ unknownMethod queryMethod queryId + Just handler -> runHandler handler addr q + +{----------------------------------------------------------------------- +-- Listener +-----------------------------------------------------------------------} + +handleQuery :: MonadKRPC m => KQuery -> SockAddr -> m () +handleQuery q addr = do + Manager {..} <- getManager + res <- dispatchHandler q addr + sendMessage sock addr $ either toBEncode toBEncode res + +handleResponse :: MonadKRPC m => KResult -> SockAddr -> m () +handleResponse result addr = do + Manager {..} <- getManager + mcall <- undefined (addr, respId) pendingCalls + case mcall of + Nothing -> return () + Just ares -> liftIO $ putMVar ares result + +handleMessage :: MonadKRPC m => KMessage -> SockAddr -> m () +handleMessage (Q q) = handleQuery q +handleMessage (R r) = handleResponse (Right r) +handleMessage (E e) = handleResponse (Left e) + +maxMsgSize :: Int +maxMsgSize = 64 * 1024 + +listener :: MonadKRPC m => m () +listener = do + Manager {..} <- getManager + forever $ do + (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize + case BE.decode bs of + Left e -> liftIO $ sendMessage sock addr $ unknownMessage e + Right m -> handleMessage m addr diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index a70c2ea9..3bbfb1db 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -19,10 +19,17 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.KRPC.Message - ( -- * Error - ErrorCode (..) + ( -- * Transaction + TransactionId + , unknownTransaction + + -- * Error + , ErrorCode (..) , KError(..) , serverError + , decodeError + , unknownMethod + , unknownMessage -- * Query , KQuery(..) @@ -30,6 +37,9 @@ module Network.KRPC.Message -- * Response , KResponse(..) + + -- * Message + , KMessage (..) ) where import Control.Applicative @@ -47,6 +57,9 @@ import Data.Typeable -- are enough as they cover 2^16 outstanding queries. type TransactionId = ByteString +unknownTransaction :: TransactionId +unknownTransaction = "" + {----------------------------------------------------------------------- -- Error messages -----------------------------------------------------------------------} @@ -120,6 +133,15 @@ instance Exception KError serverError :: SomeException -> TransactionId -> KError serverError e = KError ServerError (BC.pack (show e)) +decodeError :: String -> TransactionId -> KError +decodeError msg = KError ProtocolError (BC.pack msg) + +unknownMethod :: MethodName -> TransactionId -> KError +unknownMethod = KError MethodUnknown + +unknownMessage :: String -> KError +unknownMessage msg = KError ProtocolError (BC.pack msg) "" + {----------------------------------------------------------------------- -- Query messages -----------------------------------------------------------------------} @@ -183,4 +205,23 @@ instance BEncode KResponse where fromBEncode = fromDict $ do lookAhead $ match "y" (BString "r") KResponse <$>! "r" <*>! "t" - {-# INLINE fromBEncode #-} \ No newline at end of file + {-# INLINE fromBEncode #-} + +{----------------------------------------------------------------------- +-- Summed messages +-----------------------------------------------------------------------} + +data KMessage + = Q KQuery + | R KResponse + | E KError + +instance BEncode KMessage where + toBEncode (Q q) = toBEncode q + toBEncode (R r) = toBEncode r + toBEncode (E e) = toBEncode e + + fromBEncode b = + Q <$> fromBEncode b + <|> R <$> fromBEncode b + <|> E <$> fromBEncode b diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs new file mode 100644 index 00000000..54aa8ef0 --- /dev/null +++ b/src/Network/KRPC/Method.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.KRPC.Method + ( Method (..) + , KRPC (..) + ) where + +import Data.BEncode (BEncode) +import Data.Monoid +import Data.String +import Data.Typeable +import Network.KRPC.Message + + +-- | Method datatype used to describe name, parameters and return +-- values of procedure. Client use a method to /invoke/, server +-- /implements/ the method to make the actual work. +-- +-- We use the following fantom types to ensure type-safiety: +-- +-- * param: Type of method parameters. Ordinary Tuple type used +-- to specify more than one parameter, so for example @Method +-- (Int, Int) result@ will take two arguments. +-- +-- * result: Type of return value of the method. Similarly, +-- tuple used to specify more than one return value, so for +-- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments +-- and return two values. +-- +newtype Method param result = Method MethodName + deriving (Eq, Ord, IsString, BEncode) + +instance (Typeable a, Typeable b) => Show (Method a b) where + showsPrec _ = showsMethod + +showsMethod :: forall a. forall b. Typeable a => Typeable b + => Method a b -> ShowS +showsMethod (Method name) = + shows name <> + showString " :: " <> + shows paramsTy <> + showString " -> " <> + shows valuesTy + where + impossible = error "KRPC.showsMethod: impossible" + paramsTy = typeOf (impossible :: a) + valuesTy = typeOf (impossible :: b) + +-- | Example: +-- @ +-- data Ping = Ping Text deriving BEncode +-- data Pong = Pong Text deriving BEncode +-- +-- instance KRPC Ping Pong where +-- method = "ping" +-- @ +class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where + method :: Method req resp -- cgit v1.2.3 From 663b47b5aab9c967c82c6b0678f5bb5e10d93fc4 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 20 Dec 2013 00:34:22 +0400 Subject: Add default method for KRPC class --- src/Network/KRPC/Method.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index 54aa8ef0..f2461a1b 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -2,14 +2,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} module Network.KRPC.Method ( Method (..) , KRPC (..) ) where import Data.BEncode (BEncode) +import Data.Char import Data.Monoid +import Data.List as L import Data.String import Data.Typeable import Network.KRPC.Message @@ -59,3 +62,8 @@ showsMethod (Method name) = -- @ class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where method :: Method req resp + + default method :: Typeable req => Method req resp + method = Method $ fromString $ L.map toLower $ show $ typeOf hole + where + hole = error "krpc.method: impossible" :: req -- cgit v1.2.3 From 3cbfda28704a6963baf8bcd919826b0ae67b2a5a Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 21 Dec 2013 01:25:33 +0400 Subject: Separate KRPC monad from Handler monad --- krpc.cabal | 1 + src/Network/KRPC.hs | 14 ++---- src/Network/KRPC/Manager.hs | 105 +++++++++++++++++++++++++++++--------------- 3 files changed, 74 insertions(+), 46 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index bccdd6c3..f80b462c 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -45,6 +45,7 @@ library , bytestring >= 0.10 , lifted-base >= 0.1.1 , transformers >= 0.2 + , mtl , monad-control >= 0.3 , bencoding >= 0.4.3 , network >= 2.3 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 09d1c5b2..6809a330 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -86,16 +86,6 @@ -- -- For protocol details see 'Remote.KRPC.Protocol' module. -- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FunctionalDependencies #-} module Network.KRPC ( -- * Methods Method @@ -103,10 +93,12 @@ module Network.KRPC -- * RPC , handler + , listen , query -- * Manager , MonadKRPC (..) + , Manager , newManager -- , closeManager @@ -116,4 +108,4 @@ module Network.KRPC import Network.KRPC.Message import Network.KRPC.Method -import Network.KRPC.Manager \ No newline at end of file +import Network.KRPC.Manager diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 9aa1bea7..64b0dd62 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -1,29 +1,40 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} module Network.KRPC.Manager ( MonadKRPC (..) + , Manager , newManager + , closeManager , query + , handler + , listener + , listen ) where import Control.Applicative import Control.Arrow import Control.Concurrent ---import Control.Exception hiding (Handler) -import Control.Exception.Lifted as Lifted hiding (Handler) +import Control.Concurrent.Lifted (fork) +import Control.Exception hiding (Handler) +import Control.Exception.Lifted as Lifted (catch) import Control.Monad +import Control.Monad.Reader import Control.Monad.Trans.Control -import Control.Monad.IO.Class import Data.BEncode as BE import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL import Data.IORef import Data.List as L import Data.Map as M +import Data.Tuple import Network.KRPC.Message import Network.KRPC.Method -import Network.Socket +import Network.Socket hiding (listen) import Network.Socket.ByteString as BS @@ -34,18 +45,27 @@ type CallId = (TransactionId, SockAddr) type CallRes = MVar KResult type PendingCalls = IORef (Map CallId CallRes) -type HandlerBody m = SockAddr -> BValue -> m (BE.Result BValue) -type Handler m = (MethodName, HandlerBody m) +type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue) +type Handler h = (MethodName, HandlerBody h) -data Manager m = Manager +data Manager h = Manager { sock :: !Socket , transactionCounter :: {-# UNPACK #-} !TransactionCounter , pendingCalls :: {-# UNPACK #-} !PendingCalls - , handlers :: [Handler m] + , handlers :: [Handler h] } -class (MonadBaseControl IO m, MonadIO m) => MonadKRPC m where - getManager :: m (Manager a) +class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where + getManager :: m (Manager h) + + default getManager :: MonadReader (Manager h) m => m (Manager h) + getManager = ask + + liftHandler :: h a -> m a + +instance (MonadBaseControl IO h, MonadIO h) + => MonadKRPC h (ReaderT (Manager h) h) where + liftHandler = lift sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET @@ -55,12 +75,12 @@ sockAddrFamily (SockAddrUnix _ ) = AF_UNIX seedTransaction :: Int seedTransaction = 0 -newManager :: SockAddr -> IO (Manager a) -newManager servAddr = do +newManager :: SockAddr -> [Handler h] -> IO (Manager h) +newManager servAddr handlers = do sock <- bindServ tran <- newIORef seedTransaction calls <- newIORef M.empty - return $ Manager sock tran calls [] + return $ Manager sock tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -70,8 +90,14 @@ newManager servAddr = do bindSocket sock servAddr return sock +-- | Unblock all pending calls and close socket. +closeManager :: Manager m -> IO () +closeManager Manager {..} = do + -- TODO unblock calls + close sock + sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () -sendMessage sock addr a = +sendMessage sock addr a = do liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr {----------------------------------------------------------------------- @@ -89,9 +115,10 @@ registerQuery cid ref = do atomicModifyIORef' ref $ \ m -> (M.insert cid ares m, ()) return ares -unregisterQuery :: CallId -> PendingCalls -> IO () +unregisterQuery :: CallId -> PendingCalls -> IO (Maybe CallRes) unregisterQuery cid ref = do - atomicModifyIORef' ref $ \ m -> (M.delete cid m, ()) + atomicModifyIORef' ref $ swap . + M.updateLookupWithKey (const (const Nothing)) cid queryResponse :: BEncode a => CallRes -> IO a queryResponse ares = do @@ -103,7 +130,7 @@ queryResponse ares = do Left e -> throwIO (KError ProtocolError (BC.pack e) respId) Right a -> return a -query :: forall m a b. (MonadKRPC m, KRPC a b) => SockAddr -> a -> m b +query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do Manager {..} <- getManager liftIO $ do @@ -113,55 +140,60 @@ query addr params = do ares <- registerQuery (tid, addr) pendingCalls sendMessage sock addr q `onException` unregisterQuery (tid, addr) pendingCalls - queryResponse ares + res <- queryResponse ares + return res {----------------------------------------------------------------------- -- Handlers -----------------------------------------------------------------------} -handler :: forall m a b. (KRPC a b, MonadKRPC m) - => (SockAddr -> a -> m b) -> Handler m +handler :: forall h a b. (KRPC a b, Monad h) + => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) where Method name = method :: Method a b wrapper addr args = case fromBEncode args of Left e -> return $ Left e - Right a -> (Right . toBEncode) <$> body addr a + Right a -> do + r <- body addr a + return $ Right $ toBEncode r -runHandler :: MonadKRPC m => HandlerBody m -> SockAddr -> KQuery -> m KResult -runHandler handler addr KQuery {..} = wrapper `Lifted.catch` failback +runHandler :: MonadKRPC h m => HandlerBody h -> SockAddr -> KQuery -> m KResult +runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback where wrapper = ((`decodeError` queryId) +++ (`KResponse` queryId)) - <$> handler addr queryArgs + <$> liftHandler (h addr queryArgs) failback e = return $ Left $ serverError e queryId -dispatchHandler :: MonadKRPC m => KQuery -> SockAddr -> m KResult +dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult dispatchHandler q @ KQuery {..} addr = do Manager {..} <- getManager case L.lookup queryMethod handlers of - Nothing -> return $ Left $ unknownMethod queryMethod queryId - Just handler -> runHandler handler addr q + Nothing -> return $ Left $ unknownMethod queryMethod queryId + Just h -> runHandler h addr q {----------------------------------------------------------------------- -- Listener -----------------------------------------------------------------------} -handleQuery :: MonadKRPC m => KQuery -> SockAddr -> m () +handleQuery :: MonadKRPC h m => KQuery -> SockAddr -> m () handleQuery q addr = do Manager {..} <- getManager res <- dispatchHandler q addr sendMessage sock addr $ either toBEncode toBEncode res -handleResponse :: MonadKRPC m => KResult -> SockAddr -> m () +handleResponse :: MonadKRPC h m => KResult -> SockAddr -> m () handleResponse result addr = do Manager {..} <- getManager - mcall <- undefined (addr, respId) pendingCalls - case mcall of - Nothing -> return () - Just ares -> liftIO $ putMVar ares result + liftIO $ do + let resultId = either errorId respId result + mcall <- unregisterQuery (resultId, addr) pendingCalls + case mcall of + Nothing -> return () + Just ares -> putMVar ares result -handleMessage :: MonadKRPC m => KMessage -> SockAddr -> m () +handleMessage :: MonadKRPC h m => KMessage -> SockAddr -> m () handleMessage (Q q) = handleQuery q handleMessage (R r) = handleResponse (Right r) handleMessage (E e) = handleResponse (Left e) @@ -169,7 +201,7 @@ handleMessage (E e) = handleResponse (Left e) maxMsgSize :: Int maxMsgSize = 64 * 1024 -listener :: MonadKRPC m => m () +listener :: MonadKRPC h m => m () listener = do Manager {..} <- getManager forever $ do @@ -177,3 +209,6 @@ listener = do case BE.decode bs of Left e -> liftIO $ sendMessage sock addr $ unknownMessage e Right m -> handleMessage m addr + +listen :: MonadKRPC h m => m ThreadId +listen = fork $ listener -- cgit v1.2.3 From a6358e332e8b2820541fd75a426d92428c27c58f Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 03:09:01 +0400 Subject: Expose Handler type synonym --- src/Network/KRPC.hs | 3 ++- src/Network/KRPC/Manager.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 6809a330..e10fcb58 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -92,6 +92,7 @@ module Network.KRPC , KRPC (..) -- * RPC + , Handler , handler , listen , query @@ -100,7 +101,7 @@ module Network.KRPC , MonadKRPC (..) , Manager , newManager --- , closeManager + , closeManager -- * Exceptions , KError (..) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 64b0dd62..4a3dc93f 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -11,6 +11,7 @@ module Network.KRPC.Manager , closeManager , query + , Handler , handler , listener , listen -- cgit v1.2.3 From c61a5412e2ca22f6da783182261fbb0d7e8d9217 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 04:51:06 +0400 Subject: Throw exception if query takes too long --- src/Network/KRPC/Manager.hs | 31 +++++++++++++++++++++---------- src/Network/KRPC/Message.hs | 14 +++++++++++++- 2 files changed, 34 insertions(+), 11 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 4a3dc93f..0b090e6b 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -37,6 +37,7 @@ import Network.KRPC.Message import Network.KRPC.Method import Network.Socket hiding (listen) import Network.Socket.ByteString as BS +import System.Timeout type KResult = Either KError KResponse @@ -51,6 +52,7 @@ type Handler h = (MethodName, HandlerBody h) data Manager h = Manager { sock :: !Socket + , queryTimeout :: !Int -- ^ in seconds , transactionCounter :: {-# UNPACK #-} !TransactionCounter , pendingCalls :: {-# UNPACK #-} !PendingCalls , handlers :: [Handler h] @@ -76,12 +78,15 @@ sockAddrFamily (SockAddrUnix _ ) = AF_UNIX seedTransaction :: Int seedTransaction = 0 +defaultQueryTimeout :: Int +defaultQueryTimeout = 10 + newManager :: SockAddr -> [Handler h] -> IO (Manager h) newManager servAddr handlers = do sock <- bindServ tran <- newIORef seedTransaction calls <- newIORef M.empty - return $ Manager sock tran calls handlers + return $ Manager sock defaultQueryTimeout tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -116,6 +121,8 @@ registerQuery cid ref = do atomicModifyIORef' ref $ \ m -> (M.insert cid ares m, ()) return ares +-- simultaneous M.lookup and M.delete guarantees that we never get two +-- or more responses to the same query unregisterQuery :: CallId -> PendingCalls -> IO (Maybe CallRes) unregisterQuery cid ref = do atomicModifyIORef' ref $ swap . @@ -123,13 +130,11 @@ unregisterQuery cid ref = do queryResponse :: BEncode a => CallRes -> IO a queryResponse ares = do - res <- readMVar ares - case res of - Left e -> throwIO e - Right (KResponse {..}) -> - case fromBEncode respVals of - Left e -> throwIO (KError ProtocolError (BC.pack e) respId) - Right a -> return a + res <- readMVar ares + KResponse {..} <- either throwIO pure res + case fromBEncode respVals of + Right r -> pure r + Left e -> throwIO $ decodeError e respId query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do @@ -138,11 +143,17 @@ query addr params = do tid <- genTransactionId transactionCounter let Method name = method :: Method a b let q = KQuery (toBEncode params) name tid + ares <- registerQuery (tid, addr) pendingCalls sendMessage sock addr q `onException` unregisterQuery (tid, addr) pendingCalls - res <- queryResponse ares - return res + + mres <- timeout (queryTimeout * 10 ^ 6) $ queryResponse ares + case mres of + Just res -> return res + Nothing -> do + unregisterQuery (tid, addr) pendingCalls + throwIO $ timeoutExpired tid {----------------------------------------------------------------------- -- Handlers diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 3bbfb1db..0bd34400 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -30,6 +30,7 @@ module Network.KRPC.Message , decodeError , unknownMethod , unknownMessage + , timeoutExpired -- * Query , KQuery(..) @@ -130,17 +131,28 @@ instance BEncode KError where instance Exception KError +-- | Happen when some handler fail. serverError :: SomeException -> TransactionId -> KError serverError e = KError ServerError (BC.pack (show e)) +-- | Received 'queryArgs' or 'respVals' can not be decoded. decodeError :: String -> TransactionId -> KError decodeError msg = KError ProtocolError (BC.pack msg) +-- | If /remote/ node send query /this/ node doesn't know about then +-- this error message should be sent in response. unknownMethod :: MethodName -> TransactionId -> KError unknownMethod = KError MethodUnknown +-- | A remote node has send some 'KMessage' this node is unable to +-- decode. unknownMessage :: String -> KError -unknownMessage msg = KError ProtocolError (BC.pack msg) "" +unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction + +-- | A /remote/ node is not responding to the /our/ request the for +-- specified period of time. +timeoutExpired :: TransactionId -> KError +timeoutExpired = KError GenericError "timeout expired" {----------------------------------------------------------------------- -- Query messages -- cgit v1.2.3 From ca59e5cfac34d8a59203e91fdd9dd432f537c346 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 04:56:48 +0400 Subject: Fix warnings --- src/Network/KRPC/Manager.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 0b090e6b..c63967d0 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -148,11 +148,13 @@ query addr params = do sendMessage sock addr q `onException` unregisterQuery (tid, addr) pendingCalls - mres <- timeout (queryTimeout * 10 ^ 6) $ queryResponse ares + mres <- timeout (queryTimeout * 10 ^ (6 :: Int)) $ do + queryResponse ares + case mres of Just res -> return res Nothing -> do - unregisterQuery (tid, addr) pendingCalls + _ <- unregisterQuery (tid, addr) pendingCalls throwIO $ timeoutExpired tid {----------------------------------------------------------------------- -- cgit v1.2.3 From ce8a1546bdcfbbb7c45407e3811cafc99d667ee1 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 05:08:51 +0400 Subject: Run each handler in separate thread. This is needed because handler can call query too. The minimal example: * listener received KQuery(1); * listener dispatch corresponding handler; * handler send KQuery(2); * handler blocked waiting for response; * listener is unable to receive KQuery(2) because it is blocked on handler. So we should run each handler in separated thread otherwise dead lock can happen. --- src/Network/KRPC/Manager.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index c63967d0..084a8d8d 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -192,7 +192,7 @@ dispatchHandler q @ KQuery {..} addr = do -----------------------------------------------------------------------} handleQuery :: MonadKRPC h m => KQuery -> SockAddr -> m () -handleQuery q addr = do +handleQuery q addr = void $ fork $ do Manager {..} <- getManager res <- dispatchHandler q addr sendMessage sock addr $ either toBEncode toBEncode res -- cgit v1.2.3 From c0377edb380e49be5bd2d1cdb3c5a7dc612b57b5 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 05:16:05 +0400 Subject: More permissive default query timeout --- src/Network/KRPC/Manager.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 084a8d8d..304f43f2 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -79,7 +79,7 @@ seedTransaction :: Int seedTransaction = 0 defaultQueryTimeout :: Int -defaultQueryTimeout = 10 +defaultQueryTimeout = 120 newManager :: SockAddr -> [Handler h] -> IO (Manager h) newManager servAddr handlers = do -- cgit v1.2.3 From 12a07d236274d154846100d27e8d3a33e430ad12 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 22 Dec 2013 05:46:05 +0400 Subject: Update cabal description --- krpc.cabal | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index f80b462c..908fd770 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -12,10 +12,13 @@ tested-with: GHC == 7.4.1 , GHC == 7.6.3 homepage: https://github.com/cobit/krpc bug-reports: https://github.com/cobit/krpc/issues -synopsis: KRPC remote procedure call protocol implementation. +synopsis: KRPC protocol implementation description: - KRPC remote procedure call protocol implementation. + The KRPC protocol is a simple RPC mechanism consisting of bencoded + dictionaries sent over UDP. + . + extra-source-files: README.md , changelog -- cgit v1.2.3 From 857988ceb7c9d73926c07bb1522ce86a1669f4c5 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Mon, 23 Dec 2013 03:28:54 +0400 Subject: Add spec for Message module --- krpc.cabal | 34 +++++++++++++------ src/Network/KRPC/Message.hs | 1 + tests/Network/KRPC/MessageSpec.hs | 71 +++++++++++++++++++++++++++++++++++++++ tests/Spec.hs | 1 + 4 files changed, 97 insertions(+), 10 deletions(-) create mode 100644 tests/Network/KRPC/MessageSpec.hs create mode 100644 tests/Spec.hs diff --git a/krpc.cabal b/krpc.cabal index 908fd770..fb7b01fe 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -59,25 +59,39 @@ library ghc-options: -Wall - -test-suite test-client +test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests - main-is: Client.hs - other-modules: Shared + main-is: Spec.hs build-depends: base == 4.* , bytestring - , process - , filepath + + , hspec + , QuickCheck + , quickcheck-instances , bencoding , krpc - , network - , HUnit - , test-framework - , test-framework-hunit +--test-suite test-client +-- type: exitcode-stdio-1.0 +-- default-language: Haskell2010 +-- hs-source-dirs: tests +-- main-is: Client.hs +-- other-modules: Shared +-- build-depends: base == 4.* +-- , bytestring +-- , process +-- , filepath +-- +-- , bencoding +-- , krpc +-- , network +-- +-- , HUnit +-- , test-framework +-- , test-framework-hunit --executable test-server diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 0bd34400..1e1dc065 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -227,6 +227,7 @@ data KMessage = Q KQuery | R KResponse | E KError + deriving (Show, Eq) instance BEncode KMessage where toBEncode (Q q) = toBEncode q diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs new file mode 100644 index 00000000..7aca4489 --- /dev/null +++ b/tests/Network/KRPC/MessageSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MessageSpec (spec) where +import Control.Applicative +import Data.ByteString.Lazy as BL +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Data.BEncode as BE +import Network.KRPC.Message + +instance Arbitrary ErrorCode where + arbitrary = arbitraryBoundedEnum + +instance Arbitrary KError where + arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary KQuery where + arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary + +instance Arbitrary KResponse where + arbitrary = KResponse <$> pure (BList []) <*> arbitrary + +instance Arbitrary KMessage where + arbitrary = frequency + [ (1, Q <$> arbitrary) + , (1, R <$> arbitrary) + , (1, E <$> arbitrary) + ] + +spec :: Spec +spec = do + describe "error message" $ do + it "properly bencoded (iso)" $ property $ \ ke -> + BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError) + + it "properly bencoded" $ do + BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee" + `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa") + + BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee" + `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb") + + BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee" + `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc") + + BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee" + `shouldBe` Right + (KError MethodUnknown "Attempt to call unknown method" "dd") + + describe "query message" $ do + it "properly bencoded (iso)" $ property $ \ kq -> + BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery) + + it "properly bencoded" $ do + BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe` + Right (KQuery (BList []) "ping" "aa") + + + describe "response message" $ do + it "properly bencoded (iso)" $ property $ \ kr -> + BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse) + + it "properly bencoded" $ do + BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` + Right (KResponse (BList []) "aa") + + describe "generic message" $ do + it "properly bencoded (iso)" $ property $ \ km -> + BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) \ No newline at end of file diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 index 00000000..52ef578f --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} \ No newline at end of file -- cgit v1.2.3 From 257844fe956a4736feca82bc3e802a09fcc0977a Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Mon, 23 Dec 2013 06:22:01 +0400 Subject: Update message module documentation --- src/Network/KRPC/Message.hs | 91 ++++++++++++++++++++++++++++++--------------- src/Network/KRPC/Method.hs | 1 + 2 files changed, 61 insertions(+), 31 deletions(-) diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 1e1dc065..d6279f11 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -5,9 +5,10 @@ -- Stability : experimental -- Portability : portable -- --- This module provides straightforward implementation of KRPC --- protocol. In many situations 'Network.KRPC' should be prefered --- since it gives more safe, convenient and high level api. +-- KRPC messages types used in communication. All messages are +-- encoded as bencode dictionary. +-- +-- Normally, you don't need to import this module. -- -- See -- @@ -21,7 +22,6 @@ module Network.KRPC.Message ( -- * Transaction TransactionId - , unknownTransaction -- * Error , ErrorCode (..) @@ -65,6 +65,7 @@ unknownTransaction = "" -- Error messages -----------------------------------------------------------------------} +-- | Types of RPC errors. data ErrorCode -- | Some error doesn't fit in any other category. = GenericError @@ -79,6 +80,8 @@ data ErrorCode | MethodUnknown deriving (Show, Read, Eq, Ord, Bounded, Typeable) +-- | According to the table: +-- instance Enum ErrorCode where fromEnum GenericError = 201 fromEnum ServerError = 202 @@ -100,22 +103,31 @@ instance BEncode ErrorCode where fromBEncode b = toEnum <$> fromBEncode b {-# INLINE fromBEncode #-} --- | Errors used to signal that some error occurred while processing a --- procedure call. Error may be send only from server to client but --- not in the opposite direction. --- --- Errors are encoded as bencoded dictionary: --- --- > { "y" : "e", "e" : [, ] } +-- | Errors are sent when a query cannot be fulfilled. Error message +-- can be send only from server to client but not in the opposite +-- direction. -- data KError = KError - { errorCode :: !ErrorCode - , errorMessage :: !ByteString - , errorId :: !TransactionId + { errorCode :: !ErrorCode -- ^ the type of error; + , errorMessage :: !ByteString -- ^ human-readable text message; + , errorId :: !TransactionId -- ^ match to the corresponding 'queryId'. } deriving (Show, Read, Eq, Ord, Typeable) +-- | Errors, or KRPC message dictionaries with a \"y\" value of \"e\", +-- contain one additional key \"e\". The value of \"e\" is a +-- list. The first element is an integer representing the error +-- code. The second element is a string containing the error +-- message. +-- +-- Example Error Packet: +-- +-- > { "t": "aa", "y":"e", "e":[201, "A Generic Error Ocurred"]} +-- +-- or bencoded: +-- +-- > d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee +-- instance BEncode KError where - toBEncode KError {..} = toDict $ "e" .=! (errorCode, errorMessage) .: "t" .=! errorId @@ -131,7 +143,7 @@ instance BEncode KError where instance Exception KError --- | Happen when some handler fail. +-- | Happen when some query handler fail. serverError :: SomeException -> TransactionId -> KError serverError e = KError ServerError (BC.pack (show e)) @@ -164,16 +176,21 @@ type MethodName = ByteString -- callee and pass arguments in. Therefore query may be only sent from -- client to server but not in the opposite direction. -- --- Queries are encoded as bencoded dictionary: --- --- > { "y" : "q", "q" : "", "a" : [, , ...] } --- data KQuery = KQuery - { queryArgs :: !BValue - , queryMethod :: !MethodName - , queryId :: !TransactionId + { queryArgs :: !BValue -- ^ values to be passed to method; + , queryMethod :: !MethodName -- ^ method to call; + , queryId :: !TransactionId -- ^ one-time query token. } deriving (Show, Read, Eq, Ord, Typeable) +-- | Queries, or KRPC message dictionaries with a \"y\" value of +-- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has +-- a string value containing the method name of the query. Key \"a\" +-- has a dictionary value containing named arguments to the query. +-- +-- Example Query packet: +-- +-- > { "t" : "aa", "y" : "q", "q" : "ping", "a" : { "msg" : "hi!" } } +-- instance BEncode KQuery where toBEncode KQuery {..} = toDict $ "a" .=! queryArgs @@ -192,20 +209,30 @@ instance BEncode KQuery where -- Response messages -----------------------------------------------------------------------} --- | KResponse used to signal that callee successufully process a --- procedure call and to return values from procedure. KResponse should --- not be sent if error occurred during RPC. Thus KResponse may be only --- sent from server to client. +-- | Response messages are sent upon successful completion of a +-- query: -- --- Responses are encoded as bencoded dictionary: +-- * KResponse used to signal that callee successufully process a +-- procedure call and to return values from procedure. -- --- > { "y" : "r", "r" : [, , ...] } +-- * KResponse should not be sent if error occurred during RPC, +-- 'KError' should be sent instead. +-- +-- * KResponse can be only sent from server to client. -- data KResponse = KResponse - { respVals :: BValue - , respId :: TransactionId + { respVals :: BValue -- ^ 'BDict' containing return values; + , respId :: TransactionId -- ^ match to the corresponding 'queryId'. } deriving (Show, Read, Eq, Ord, Typeable) +-- | Responses, or KRPC message dictionaries with a \"y\" value of +-- \"r\", contain one additional key \"r\". The value of \"r\" is a +-- dictionary containing named return values. +-- +-- Example Response packet: +-- +-- > { "t" : "aa", "y" : "r", "r" : { "msg" : "you've sent: hi!" } } +-- instance BEncode KResponse where toBEncode KResponse {..} = toDict $ "r" .=! respVals @@ -223,6 +250,7 @@ instance BEncode KResponse where -- Summed messages -----------------------------------------------------------------------} +-- | Generic KRPC message. data KMessage = Q KQuery | R KResponse @@ -238,3 +266,4 @@ instance BEncode KMessage where Q <$> fromBEncode b <|> R <$> fromBEncode b <|> E <$> fromBEncode b + <|> decodingError "KMessage: unknown message or message tag" \ No newline at end of file diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index f2461a1b..f4392f35 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -63,6 +63,7 @@ showsMethod (Method name) = class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where method :: Method req resp + -- TODO add underscores default method :: Typeable req => Method req resp method = Method $ fromString $ L.map toLower $ show $ typeOf hole where -- cgit v1.2.3 From 10829a428735d034f927e45561dcf94703cd376a Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 24 Dec 2013 06:28:23 +0400 Subject: Update documentation in Method module --- src/Network/KRPC/Method.hs | 45 +++++++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index f4392f35..f70923f5 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -1,3 +1,12 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Normally, you don't need to import this module. +-- {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} @@ -10,6 +19,7 @@ module Network.KRPC.Method ) where import Data.BEncode (BEncode) +import Data.ByteString.Char8 as BC import Data.Char import Data.Monoid import Data.List as L @@ -18,31 +28,30 @@ import Data.Typeable import Network.KRPC.Message --- | Method datatype used to describe name, parameters and return --- values of procedure. Client use a method to /invoke/, server --- /implements/ the method to make the actual work. +-- | Method datatype used to describe method name, parameters and +-- return values of procedure. Client use a method to /invoke/, server +-- /implements/ the method to make the actual work. -- -- We use the following fantom types to ensure type-safiety: -- --- * param: Type of method parameters. Ordinary Tuple type used --- to specify more than one parameter, so for example @Method --- (Int, Int) result@ will take two arguments. +-- * param: Type of method parameters. -- --- * result: Type of return value of the method. Similarly, --- tuple used to specify more than one return value, so for --- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments --- and return two values. +-- * result: Type of return value of the method. -- newtype Method param result = Method MethodName deriving (Eq, Ord, IsString, BEncode) +-- | Example: +-- +-- @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@ +-- instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod showsMethod :: forall a. forall b. Typeable a => Typeable b => Method a b -> ShowS showsMethod (Method name) = - shows name <> + showString (BC.unpack name) <> showString " :: " <> shows paramsTy <> showString " -> " <> @@ -52,15 +61,23 @@ showsMethod (Method name) = paramsTy = typeOf (impossible :: a) valuesTy = typeOf (impossible :: b) --- | Example: +-- | In order to perform or handle KRPC query you need to provide +-- corresponding 'KRPC' class. +-- +-- Example: +-- -- @ -- data Ping = Ping Text deriving BEncode -- data Pong = Pong Text deriving BEncode -- --- instance KRPC Ping Pong where --- method = "ping" +-- instance 'KRPC' Ping Pong where +-- method = \"ping\" -- @ +-- class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where + -- | Method name. Default implementation uses lowercased @req@ + -- datatype name. + -- method :: Method req resp -- TODO add underscores -- cgit v1.2.3 From 46b6ba10202b73ba413d18bd21a284e3897c12b0 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 24 Dec 2013 23:50:23 +0400 Subject: Update tests --- krpc.cabal | 54 +++++++-------------------- src/Network/KRPC.hs | 4 +- src/Network/KRPC/Manager.hs | 12 ++++++ tests/Client.hs | 80 ---------------------------------------- tests/Network/KRPC/MethodSpec.hs | 52 ++++++++++++++++++++++++++ tests/Network/KRPCSpec.hs | 33 +++++++++++++++++ tests/Server.hs | 20 ---------- tests/Shared.hs | 39 -------------------- 8 files changed, 114 insertions(+), 180 deletions(-) delete mode 100644 tests/Client.hs create mode 100644 tests/Network/KRPC/MethodSpec.hs create mode 100644 tests/Network/KRPCSpec.hs delete mode 100644 tests/Server.hs delete mode 100644 tests/Shared.hs diff --git a/krpc.cabal b/krpc.cabal index fb7b01fe..c4c0ae10 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -64,8 +64,13 @@ test-suite spec default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs + other-modules: Network.KRPCSpec + Network.KRPC.MethodSpec + Network.KRPC.MessageSpec build-depends: base == 4.* , bytestring + , network + , mtl , hspec , QuickCheck @@ -74,55 +79,24 @@ test-suite spec , bencoding , krpc ---test-suite test-client --- type: exitcode-stdio-1.0 --- default-language: Haskell2010 --- hs-source-dirs: tests --- main-is: Client.hs --- other-modules: Shared --- build-depends: base == 4.* --- , bytestring --- , process --- , filepath --- --- , bencoding --- , krpc --- , network --- --- , HUnit --- , test-framework --- , test-framework-hunit - - ---executable test-server +--executable bench-server -- default-language: Haskell2010 --- hs-source-dirs: tests +-- hs-source-dirs: bench -- main-is: Server.hs --- other-modules: Shared -- build-depends: base == 4.* -- , bytestring --- , bencoding -- , krpc -- , network +-- ghc-options: -fforce-recomp ---executable bench-server +--benchmark bench-client +-- type: exitcode-stdio-1.0 -- default-language: Haskell2010 -- hs-source-dirs: bench --- main-is: Server.hs --- build-depends: base == 4.* +-- main-is: Main.hs +-- build-depends: base == 4.* -- , bytestring +-- , criterion -- , krpc -- , network --- ghc-options: -fforce-recomp - -benchmark bench-client - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: bench - main-is: Main.hs - build-depends: base == 4.* - , bytestring - , criterion - , krpc - , network - ghc-options: -O2 -fforce-recomp \ No newline at end of file +-- ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index e10fcb58..10d2eb55 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -94,7 +94,6 @@ module Network.KRPC -- * RPC , Handler , handler - , listen , query -- * Manager @@ -102,9 +101,12 @@ module Network.KRPC , Manager , newManager , closeManager + , withManager + , listen -- * Exceptions , KError (..) + , ErrorCode (..) ) where import Network.KRPC.Message diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 304f43f2..9d8688d3 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -9,6 +9,8 @@ module Network.KRPC.Manager , Manager , newManager , closeManager + , withManager + , query , Handler @@ -102,6 +104,9 @@ closeManager Manager {..} = do -- TODO unblock calls close sock +withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a +withManager addr hs = bracket (newManager addr hs) closeManager + sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () sendMessage sock addr a = do liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr @@ -136,6 +141,11 @@ queryResponse ares = do Right r -> pure r Left e -> throwIO $ decodeError e respId +-- | +-- +-- This function will throw exception if quered node respond with +-- @error@ message or timeout expires. +-- query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do Manager {..} <- getManager @@ -161,6 +171,8 @@ query addr params = do -- Handlers -----------------------------------------------------------------------} +-- | Any thrown exception will be supressed and send over wire back to +-- the quering node. handler :: forall h a b. (KRPC a b, Monad h) => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) diff --git a/tests/Client.hs b/tests/Client.hs deleted file mode 100644 index 2b49bd82..00000000 --- a/tests/Client.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Control.Concurrent -import Control.Exception -import qualified Data.ByteString as B -import Data.BEncode as BE -import Data.BEncode.BDict as BE -import System.Process -import System.FilePath - -import Test.HUnit hiding (Test) -import Test.Framework -import Test.Framework.Providers.HUnit - -import Network.KRPC -import Network.Socket -import Shared - - -addr :: SockAddr -addr = SockAddrInet 6000 0 - -withServ :: FilePath -> IO () -> IO () -withServ serv_path = bracket up terminateProcess . const - where - up = do - (_, _, _, h) <- createProcess (proc serv_path []) - threadDelay 1000000 - return h - -main :: IO () -main = do - let serv_path = "dist" "build" "test-server" "test-server" - withServ serv_path $ - defaultMain tests - - -(==?) :: (Eq a, Show a) => a -> IO a -> Assertion -expected ==? action = do - actual <- action - expected @=? actual - -tests :: [Test] -tests = - [ testCase "unit" $ - () ==? call addr unitM () - - , testCase "echo int" $ - 1234 ==? call addr echoM 1234 - - , testCase "reverse 1..100" $ - reverse [1..100] ==? call addr reverseM [1..100] - - , testCase "reverse empty list" $ - reverse [] ==? call addr reverseM [] - - , testCase "reverse singleton list" $ - reverse [1] ==? call addr reverseM [1] - - , testCase "swap pair" $ - (1, 0) ==? call addr swapM (0, 1) - - , testCase "shift triple" $ - ([2..10], (), 1) ==? call addr shiftR ((), 1, [2..10]) - - , testCase "echo bytestring" $ - let bs = B.replicate 400 0 in - bs ==? call addr echoBytes bs - - , testCase "raw method" $ - BInteger 10 ==? call addr rawM (BInteger 10) - - , testCase "raw dict" $ - let dict = BDict $ BE.fromAscList - [ ("some_int", BInteger 100) - , ("some_list", BList [BInteger 10]) - ] - in dict ==? call addr rawDictM dict - ] diff --git a/tests/Network/KRPC/MethodSpec.hs b/tests/Network/KRPC/MethodSpec.hs new file mode 100644 index 00000000..c1c58282 --- /dev/null +++ b/tests/Network/KRPC/MethodSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.KRPC.MethodSpec where +import Control.Applicative +import Data.BEncode +import Data.ByteString as BS +import Data.Typeable +import Network.KRPC +import Test.Hspec + + +data Ping = Ping + deriving (Show, Eq, Typeable) + +instance BEncode Ping where + toBEncode Ping = toBEncode () + fromBEncode b = Ping <$ (fromBEncode b :: Result ()) + +instance KRPC Ping Ping + +ping :: Monad h => Handler h +ping = handler $ \ _ Ping -> return Ping + +newtype Echo a = Echo a + deriving (Show, Eq, BEncode, Typeable) + +echo :: Monad h => Handler h +echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString)) + +instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a) + +spec :: Spec +spec = do + describe "ping method" $ do + it "name is ping" $ do + (method :: Method Ping Ping) `shouldBe` "ping" + + it "has pretty Show instance" $ do + show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping" + + describe "echo method" $ do + it "is overloadable" $ do + (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int" + (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool" + + it "has pretty Show instance" $ do + show (method :: Method (Echo Int) (Echo Int)) + `shouldBe` "echo int :: Echo Int -> Echo Int" \ No newline at end of file diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs new file mode 100644 index 00000000..27148682 --- /dev/null +++ b/tests/Network/KRPCSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.KRPCSpec (spec) where +import Control.Monad.Reader +import Network.Socket (SockAddr (..)) +import Network.KRPC +import Network.KRPC.MethodSpec hiding (spec) +import Test.Hspec + +servAddr :: SockAddr +servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127) + +handlers :: [Handler IO] +handlers = + [ handler $ \ _ Ping -> return Ping + , handler $ \ _ (Echo a) -> return (Echo (a :: Bool)) + , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) + ] + +spec :: Spec +spec = do + describe "query" $ do + it "run handlers" $ do + let int = 0xabcd :: Int + (withManager servAddr handlers $ runReaderT $ do + listen + query servAddr (Echo int)) + `shouldReturn` Echo int + + it "throw timeout exception" $ do + (withManager servAddr handlers $ runReaderT $ do + query servAddr (Echo (0xabcd :: Int)) + ) + `shouldThrow` (== KError GenericError "timeout expired" "0") diff --git a/tests/Server.hs b/tests/Server.hs deleted file mode 100644 index b4b34891..00000000 --- a/tests/Server.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} -module Main (main) where - -import Data.BEncode -import Network.KRPC -import Network.Socket -import Shared - - -main :: IO () -main = server (SockAddrInet 6000 0) - [ unitM ==> return - , echoM ==> return - , echoBytes ==> return - , swapM ==> \(a, b) -> return (b, a) - , reverseM ==> return . reverse - , shiftR ==> \(a, b, c) -> return (c, a, b) - , rawM ==> return - , rawDictM ==> return - ] diff --git a/tests/Shared.hs b/tests/Shared.hs deleted file mode 100644 index 16547644..00000000 --- a/tests/Shared.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Shared - ( echoM - , echoBytes - , unitM - , swapM - , reverseM - , shiftR - , rawM - , rawDictM - ) where - -import Data.ByteString (ByteString) -import Data.BEncode -import Network.KRPC - -unitM :: Method () () -unitM = method "unit" [] [] - -echoM :: Method Int Int -echoM = method "echo" ["x"] ["x"] - -echoBytes :: Method ByteString ByteString -echoBytes = method "echoBytes" ["x"] ["x"] - -reverseM :: Method [Int] [Int] -reverseM = method "reverse" ["xs"] ["ys"] - -swapM :: Method (Int, Int) (Int, Int) -swapM = method "swap" ["x", "y"] ["b", "a"] - -shiftR :: Method ((), Int, [Int]) ([Int], (), Int) -shiftR = method "shiftR" ["x", "y", "z"] ["a", "b", "c"] - -rawM :: Method BValue BValue -rawM = method "rawM" [""] [""] - -rawDictM :: Method BValue BValue -rawDictM = method "m" [] [] \ No newline at end of file -- cgit v1.2.3 From d5bae29716f894f4f9c2623455db38260664ae16 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 00:47:43 +0400 Subject: Update benchmarks --- bench/Main.hs | 45 ++++++++++++++++++++++----------------------- bench/Server.hs | 13 ------------- krpc.cabal | 37 +++++++++++-------------------------- src/Network/KRPC.hs | 4 ++++ 4 files changed, 37 insertions(+), 62 deletions(-) delete mode 100644 bench/Server.hs diff --git a/bench/Main.hs b/bench/Main.hs index 024d4d93..97f97425 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,33 +1,32 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where - import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import Control.Monad.Reader import Criterion.Main +import Data.ByteString as BS import Network.KRPC -import Network.Socket +instance KRPC ByteString ByteString where + method = "echo" -addr :: RemoteAddr -addr = SockAddrInet 6000 0 +echo :: Handler IO +echo = handler $ \ _ bs -> return (bs :: ByteString) -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] +addr :: SockAddr +addr = SockAddrInet 6000 (256 * 256 * 256 + 127) main :: IO () -main = withRemote $ \remote -> do { - ; let sizes = [10, 100, 1000, 10000, 16 * 1024] - ; let repetitions = [1, 10, 100, 1000] - ; let params = [(r, s) | r <- repetitions, s <- sizes] - ; let benchmarks = map (uncurry (mkbench_ remote)) params - ; defaultMain benchmarks - } +main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do + listen + liftIO $ defaultMain (benchmarks m) where - mkbench_ re r n = bench (show r ++ "/" ++ show n) $ nfIO $ - replicateM r $ call_ re addr echo (B.replicate n 0) - -{- - forM_ [1..] $ const $ do - async addr myconcat (replicate 100 [1..10]) --} + sizes = [10, 100, 1000, 10000, 16 * 1024] + repetitions = [1, 10, 100, 1000] + benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] + where + mkbench m r n = + bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ + replicateM r $ + runReaderT (query addr (BS.replicate n 0)) m diff --git a/bench/Server.hs b/bench/Server.hs deleted file mode 100644 index ef20c08a..00000000 --- a/bench/Server.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Data.ByteString (ByteString) -import Network.KRPC -import Network.Socket - - -echo :: Method ByteString ByteString -echo = method "echo" ["x"] ["x"] - -main :: IO () -main = server (SockAddrInet 6000 0) [ echo ==> return ] diff --git a/krpc.cabal b/krpc.cabal index c4c0ae10..ffd23298 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -43,7 +43,6 @@ library Network.KRPC.Message Network.KRPC.Method Network.KRPC.Manager - build-depends: base == 4.* , bytestring >= 0.10 , lifted-base >= 0.1.1 @@ -53,10 +52,8 @@ library , bencoding >= 0.4.3 , network >= 2.3 , containers - if impl(ghc < 7.6) build-depends: ghc-prim - ghc-options: -Wall test-suite spec @@ -71,32 +68,20 @@ test-suite spec , bytestring , network , mtl - , hspec , QuickCheck , quickcheck-instances - , bencoding , krpc ---executable bench-server --- default-language: Haskell2010 --- hs-source-dirs: bench --- main-is: Server.hs --- build-depends: base == 4.* --- , bytestring --- , krpc --- , network --- ghc-options: -fforce-recomp - ---benchmark bench-client --- type: exitcode-stdio-1.0 --- default-language: Haskell2010 --- hs-source-dirs: bench --- main-is: Main.hs --- build-depends: base == 4.* --- , bytestring --- , criterion --- , krpc --- , network --- ghc-options: -O2 -fforce-recomp \ No newline at end of file +benchmark bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base == 4.* + , bytestring + , mtl + , criterion + , krpc + ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 10d2eb55..286c063e 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -107,8 +107,12 @@ module Network.KRPC -- * Exceptions , KError (..) , ErrorCode (..) + + -- * Re-export + , SockAddr (..) ) where import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager +import Network.Socket (SockAddr (..)) \ No newline at end of file -- cgit v1.2.3 From d59901591644413e8ff298c83242bd7d8b15d3e9 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 01:44:41 +0400 Subject: Kill listener thread at exit --- src/Network/KRPC/Manager.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 9d8688d3..a8c90b33 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -55,6 +55,7 @@ type Handler h = (MethodName, HandlerBody h) data Manager h = Manager { sock :: !Socket , queryTimeout :: !Int -- ^ in seconds + , listenerThread :: !(MVar ThreadId) , transactionCounter :: {-# UNPACK #-} !TransactionCounter , pendingCalls :: {-# UNPACK #-} !PendingCalls , handlers :: [Handler h] @@ -68,6 +69,9 @@ class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where liftHandler :: h a -> m a + default liftHandler :: m a -> m a + liftHandler = id + instance (MonadBaseControl IO h, MonadIO h) => MonadKRPC h (ReaderT (Manager h) h) where liftHandler = lift @@ -86,9 +90,10 @@ defaultQueryTimeout = 120 newManager :: SockAddr -> [Handler h] -> IO (Manager h) newManager servAddr handlers = do sock <- bindServ + tref <- newEmptyMVar tran <- newIORef seedTransaction calls <- newIORef M.empty - return $ Manager sock defaultQueryTimeout tran calls handlers + return $ Manager sock defaultQueryTimeout tref tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -101,9 +106,11 @@ newManager servAddr handlers = do -- | Unblock all pending calls and close socket. closeManager :: Manager m -> IO () closeManager Manager {..} = do + maybe (return ()) killThread =<< tryTakeMVar listenerThread -- TODO unblock calls close sock +-- | Normally you should use Control.Monad.Trans.allocate function. withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a withManager addr hs = bracket (newManager addr hs) closeManager @@ -236,5 +243,10 @@ listener = do Left e -> liftIO $ sendMessage sock addr $ unknownMessage e Right m -> handleMessage m addr -listen :: MonadKRPC h m => m ThreadId -listen = fork $ listener +-- | Should be run before any 'query', otherwise they will never +-- succeed. +listen :: MonadKRPC h m => m () +listen = do + Manager {..} <- getManager + tid <- fork $ listener + liftIO $ putMVar listenerThread tid -- cgit v1.2.3 From f0a5eec0f054f3c7e26b76a74c50a7c1f79c1e97 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 04:23:56 +0400 Subject: Update documentation --- src/Network/KRPC.hs | 52 +++++++-------------------------------------- src/Network/KRPC/Manager.hs | 31 +++++++++++++++++++-------- 2 files changed, 30 insertions(+), 53 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 286c063e..a1767161 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -6,8 +6,8 @@ -- Portability : portable -- -- This module provides safe remote procedure call. One important --- point is exceptions and errors, so be able handle them properly --- we need to investigate a bit about how this all works. +-- point is exceptions and errors, so to be able handle them +-- properly we need to investigate a bit about how this all works. -- Internally, in order to make method invokation KRPC makes the -- following steps: -- @@ -41,50 +41,14 @@ -- * Caller extracts results and finally return results of the -- procedure call as ordinary haskell values. -- --- If every other error occurred caller get the 'GenericError'. All --- errors returned by callee are throwed as ordinary haskell --- exceptions at caller side. Make sure that both callee and caller --- uses the same method signatures and everything should be ok: this --- KRPC implementation provides some level of safety through --- types. Also note that both caller and callee use plain UDP, so --- KRPC is unreliable. +-- If every other error occurred then caller get the +-- 'GenericError'. All errors returned by callee are throwed as +-- ordinary haskell exceptions at caller side. Also note that both +-- caller and callee use plain UDP, so KRPC is unreliable. -- --- Consider one tiny example. From now @caller = client@ and --- @callee = server or remote@. +-- For async 'query' use @async@ package. -- --- Somewhere we have to define all procedure signatures. Imagine --- that this is a library shared between client and server: --- --- > factorialMethod :: Method Int Int --- > factorialMethod = method "factorial" ["x"] ["y"] --- --- Otherwise you can define this code in both client and server of --- course. But in this case you might get into troubles: you can get --- 'MethodUnknown' or 'ProtocolError' if name or type of method --- will mismatch after not synced changes in client or server code. --- --- Now let's define our client-side: --- --- > main = withRemote $ \remote -> do --- > result <- call remote (0, 6000) factorialMethod 4 --- > assert (result == 24) $ print "Success!" --- --- It basically open socket with 'withRemote' and make all the other --- steps in 'call' as describe above. And finally our server-side: --- --- > factorialImpl :: Int -> Int --- > factorialImpl n = product [1..n] --- > --- > main = runServer [factorialMethod $ return . factorialImpl] --- --- Here we implement method signature from that shared lib and run --- server with runServer by passing method table in. --- --- For async API use /async/ package, old API have been removed. --- --- For more examples see @exsamples@ or @tests@ directories. --- --- For protocol details see 'Remote.KRPC.Protocol' module. +-- For protocol details see "Network.KRPC.Message" module. -- module Network.KRPC ( -- * Methods diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index a8c90b33..a883a34a 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -50,8 +50,13 @@ type CallRes = MVar KResult type PendingCalls = IORef (Map CallId CallRes) type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue) + +-- | Handler is a function which will be invoked then some /remote/ +-- node querying /this/ node. type Handler h = (MethodName, HandlerBody h) +-- | Keep track pending queries made by /this/ node and handle queries +-- made by /remote/ nodes. data Manager h = Manager { sock :: !Socket , queryTimeout :: !Int -- ^ in seconds @@ -61,12 +66,15 @@ data Manager h = Manager , handlers :: [Handler h] } +-- | A monad which can perform or handle queries. class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where + -- | Ask for manager. getManager :: m (Manager h) default getManager :: MonadReader (Manager h) m => m (Manager h) getManager = ask + -- | Can be used to add logging for instance. liftHandler :: h a -> m a default liftHandler :: m a -> m a @@ -87,7 +95,11 @@ seedTransaction = 0 defaultQueryTimeout :: Int defaultQueryTimeout = 120 -newManager :: SockAddr -> [Handler h] -> IO (Manager h) +-- | Bind socket to the specified address. To enable query handling +-- run 'listen'. +newManager :: SockAddr -- ^ address to listen on; + -> [Handler h] -- ^ handlers to run on incoming queries. + -> IO (Manager h) -- ^ new manager. newManager servAddr handlers = do sock <- bindServ tref <- newEmptyMVar @@ -110,18 +122,19 @@ closeManager Manager {..} = do -- TODO unblock calls close sock --- | Normally you should use Control.Monad.Trans.allocate function. +-- | Normally you should use Control.Monad.Trans.Resource.allocate +-- function. withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a withManager addr hs = bracket (newManager addr hs) closeManager -sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () -sendMessage sock addr a = do - liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr - {----------------------------------------------------------------------- -- Client -----------------------------------------------------------------------} +sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () +sendMessage sock addr a = do + liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr + genTransactionId :: TransactionCounter -> IO TransactionId genTransactionId ref = do cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur) @@ -148,7 +161,7 @@ queryResponse ares = do Right r -> pure r Left e -> throwIO $ decodeError e respId --- | +-- | Enqueue query to the given node. -- -- This function will throw exception if quered node respond with -- @error@ message or timeout expires. @@ -178,8 +191,8 @@ query addr params = do -- Handlers -----------------------------------------------------------------------} --- | Any thrown exception will be supressed and send over wire back to --- the quering node. +-- | Make handler from handler function. Any thrown exception will be +-- supressed and send over the wire back to the querying node. handler :: forall h a b. (KRPC a b, Monad h) => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) -- cgit v1.2.3 From c888601e87c3c52dc885ad3a1a8779ddb3a50af3 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 05:01:58 +0400 Subject: Change changlog format --- ChangeLog | 38 ++++++++++++++++++++++++++++++++++++++ changelog | 11 ----------- krpc.cabal | 2 +- 3 files changed, 39 insertions(+), 12 deletions(-) create mode 100644 ChangeLog delete mode 100644 changelog diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 00000000..5cecfed5 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,38 @@ +2013-11-26 Sam Truzjan + + * 0.4.1.1: Fixed build failure on GHC == 7.4.* + +2013-10-17 Sam Truzjan + + * 0.4.1.0: Use bencoding-0.4.* + +2013-10-03 Sam Truzjan + + * 0.4.0.1: Minor documentation fixes. + +2013-10-03 Sam Truzjan + + * 0.4.0.0: IPv6 support. + +2013-09-28 Sam Truzjan + + * 0.3.0.0: Use bencoding-0.3.* + * Rename Remote.* to Network.* modules. + +2013-09-28 Sam Truzjan + + * 0.2.2.0: Use bencoding-0.2.2.* + +2013-08-27 Sam Truzjan + + * 0.2.0.0: Async API have been removed, use /async/ package + instead. + * Expose caller address in handlers. + +2013-07-09 Sam Truzjan + + * 0.1.1.0: Allow passing raw argument\/result dictionaries. + +2013-07-09 Sam Truzjan + + * 0.1.0.0: Initial version. diff --git a/changelog b/changelog deleted file mode 100644 index edbd7faa..00000000 --- a/changelog +++ /dev/null @@ -1,11 +0,0 @@ -* 0.1.0.0: Initial version. -* 0.1.1.0: Allow passing raw argument\/result dictionaries. -* 0.2.0.0: Async API have been removed, use /async/ package instead. - Expose caller address in handlers. -* 0.2.2.0: Use bencoding-0.2.2.* -* 0.3.0.0: Use bencoding-0.3.* - Rename Remote.* to Network.* modules. -* 0.4.0.0: IPv6 support. -* 0.4.0.1: Minor documentation fixes. -* 0.4.1.0: Use bencoding-0.4.* -* 0.4.1.1: Fixed build failure on GHC == 7.4.* diff --git a/krpc.cabal b/krpc.cabal index ffd23298..5c77faf1 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -21,7 +21,7 @@ description: extra-source-files: README.md - , changelog + , ChangeLog source-repository head type: git -- cgit v1.2.3 From c0511a1037f443218baf3d2c6d4e8543998fc99b Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 05:08:43 +0400 Subject: Bump version number to 0.5.0.0 --- ChangeLog | 10 ++++++++++ krpc.cabal | 4 ++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5cecfed5..48a67416 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2013-12-25 Sam Truzjan + + 0.5.0.0: Major API changes. + + * Added transaction handling; + * Use the same socket for server and client; + * New query function will infer query method from request/response + datatypes. + * Added MonadKRPC and KRPC classes. + 2013-11-26 Sam Truzjan * 0.4.1.1: Fixed build failure on GHC == 7.4.* diff --git a/krpc.cabal b/krpc.cabal index 5c77faf1..e902c9c3 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.4.1.1 +version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -32,7 +32,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.4.1.1 + tag: v0.5.0.0 library default-language: Haskell2010 -- cgit v1.2.3 From 9a9a7d5750e24ee0810006f3dd2a7e7879b521e2 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 25 Dec 2013 05:13:38 +0400 Subject: Prettify documentation a bit --- src/Network/KRPC/Manager.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index a883a34a..6bc448c6 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -1,3 +1,12 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Normally, you don't need to import this module. +-- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} @@ -5,18 +14,18 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} module Network.KRPC.Manager - ( MonadKRPC (..) + ( -- * Manager + MonadKRPC (..) , Manager , newManager , closeManager , withManager + , listen + -- * Queries , query - , Handler , handler - , listener - , listen ) where import Control.Applicative -- cgit v1.2.3 From 3a6bedc8da60ff422e0603552d9ab1cd7abb0f9f Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Mon, 6 Jan 2014 23:41:59 +0400 Subject: Add logging to query function --- krpc.cabal | 8 ++++--- src/Network/KRPC/Manager.hs | 55 ++++++++++++++++++++++++++++++--------------- src/Network/KRPC/Method.hs | 6 +++-- 3 files changed, 46 insertions(+), 23 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index e902c9c3..7b0cafa2 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -44,13 +44,15 @@ library Network.KRPC.Method Network.KRPC.Manager build-depends: base == 4.* - , bytestring >= 0.10 + , bytestring >= 0.10 + , text >= 0.11 , lifted-base >= 0.1.1 , transformers >= 0.2 , mtl , monad-control >= 0.3 - , bencoding >= 0.4.3 - , network >= 2.3 + , monad-logger >= 0.3 + , bencoding >= 0.4.3 + , network >= 2.3 , containers if impl(ghc < 7.6) build-depends: ghc-prim diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 6bc448c6..cc2e383e 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -7,12 +7,14 @@ -- -- Normally, you don't need to import this module. -- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} module Network.KRPC.Manager ( -- * Manager MonadKRPC (..) @@ -35,6 +37,7 @@ import Control.Concurrent.Lifted (fork) import Control.Exception hiding (Handler) import Control.Exception.Lifted as Lifted (catch) import Control.Monad +import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Data.BEncode as BE @@ -43,6 +46,9 @@ import Data.ByteString.Lazy as BL import Data.IORef import Data.List as L import Data.Map as M +import Data.Monoid +import Data.Text as T +import Data.Text.Encoding as T import Data.Tuple import Network.KRPC.Message import Network.KRPC.Method @@ -76,7 +82,9 @@ data Manager h = Manager } -- | A monad which can perform or handle queries. -class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where +class (MonadBaseControl IO m, MonadLogger m, MonadIO m) + => MonadKRPC h m | m -> h where + -- | Ask for manager. getManager :: m (Manager h) @@ -89,8 +97,9 @@ class (MonadBaseControl IO m, MonadIO m) => MonadKRPC h m | m -> h where default liftHandler :: m a -> m a liftHandler = id -instance (MonadBaseControl IO h, MonadIO h) +instance (MonadBaseControl IO h, MonadLogger h, MonadIO h) => MonadKRPC h (ReaderT (Manager h) h) where + liftHandler = lift sockAddrFamily :: SockAddr -> Family @@ -178,23 +187,33 @@ queryResponse ares = do query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do Manager {..} <- getManager - liftIO $ do - tid <- genTransactionId transactionCounter - let Method name = method :: Method a b - let q = KQuery (toBEncode params) name tid - + tid <- liftIO $ genTransactionId transactionCounter + let queryMethod = method :: Method a b + let signature = T.pack (show queryMethod) + <> " @" <> T.pack (show addr) + <> " #" <> T.decodeUtf8 tid + $(logDebugS) "query.sending" signature + + mres <- liftIO $ do ares <- registerQuery (tid, addr) pendingCalls + + let q = KQuery (toBEncode params) (methodName queryMethod) tid sendMessage sock addr q `onException` unregisterQuery (tid, addr) pendingCalls - mres <- timeout (queryTimeout * 10 ^ (6 :: Int)) $ do + timeout (queryTimeout * 10 ^ (6 :: Int)) $ do queryResponse ares - case mres of - Just res -> return res - Nothing -> do - _ <- unregisterQuery (tid, addr) pendingCalls - throwIO $ timeoutExpired tid + case mres of + Just res -> do + $(logDebugS) "query.responded" $ signature + return res + + Nothing -> do + _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls + $(logWarnS) "query.not_responding" $ signature + <> " for " <> T.pack (show queryTimeout) <> " seconds" + throw $ timeoutExpired tid {----------------------------------------------------------------------- -- Handlers diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index f70923f5..68f1fa4e 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -38,7 +38,7 @@ import Network.KRPC.Message -- -- * result: Type of return value of the method. -- -newtype Method param result = Method MethodName +newtype Method param result = Method { methodName :: MethodName } deriving (Eq, Ord, IsString, BEncode) -- | Example: @@ -74,7 +74,9 @@ showsMethod (Method name) = -- method = \"ping\" -- @ -- -class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where +class (Typeable req, BEncode req, Typeable resp, BEncode resp) + => KRPC req resp | req -> resp where + -- | Method name. Default implementation uses lowercased @req@ -- datatype name. -- -- cgit v1.2.3 From 3616542dc310d9e38f6aa2b2ad30274ce4a2db91 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 00:02:10 +0400 Subject: Update tests and benchmarks --- bench/Main.hs | 8 ++++++-- krpc.cabal | 2 ++ tests/Network/KRPCSpec.hs | 8 ++++++-- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 97f97425..13727ff9 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Monad +import Control.Monad.Logger import Control.Monad.Reader import Criterion.Main import Data.ByteString as BS @@ -11,6 +12,9 @@ import Network.KRPC instance KRPC ByteString ByteString where method = "echo" +instance MonadLogger IO where + monadLoggerLog _ _ _ _ = return () + echo :: Handler IO echo = handler $ \ _ bs -> return (bs :: ByteString) @@ -26,7 +30,7 @@ main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do repetitions = [1, 10, 100, 1000] benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes] where - mkbench m r n = + mkbench action r n = bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $ replicateM r $ - runReaderT (query addr (BS.replicate n 0)) m + runReaderT (query addr (BS.replicate n 0)) action diff --git a/krpc.cabal b/krpc.cabal index 7b0cafa2..b5004026 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -70,6 +70,7 @@ test-suite spec , bytestring , network , mtl + , monad-logger , hspec , QuickCheck , quickcheck-instances @@ -84,6 +85,7 @@ benchmark bench build-depends: base == 4.* , bytestring , mtl + , monad-logger , criterion , krpc ghc-options: -O2 -fforce-recomp \ No newline at end of file diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 27148682..7f5b2794 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Network.KRPCSpec (spec) where +import Control.Monad.Logger import Control.Monad.Reader -import Network.Socket (SockAddr (..)) import Network.KRPC import Network.KRPC.MethodSpec hiding (spec) import Test.Hspec @@ -16,6 +17,9 @@ handlers = , handler $ \ _ (Echo a) -> return (Echo (a :: Int)) ] +instance MonadLogger IO where + monadLoggerLog _ _ _ _ = return () + spec :: Spec spec = do describe "query" $ do -- cgit v1.2.3 From 4e1a833637bf613a4674c7c35d4f12c811e9bf7b Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 00:34:42 +0400 Subject: Add logging at handlers --- src/Network/KRPC/Manager.hs | 40 ++++++++++++++++++++++++++++++++-------- 1 file changed, 32 insertions(+), 8 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index cc2e383e..ee336a4d 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -31,7 +31,6 @@ module Network.KRPC.Manager ) where import Control.Applicative -import Control.Arrow import Control.Concurrent import Control.Concurrent.Lifted (fork) import Control.Exception hiding (Handler) @@ -145,6 +144,17 @@ closeManager Manager {..} = do withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a withManager addr hs = bracket (newManager addr hs) closeManager +{----------------------------------------------------------------------- +-- Logging +-----------------------------------------------------------------------} + +querySignature :: MethodName -> TransactionId -> SockAddr -> Text +querySignature name transaction addr = T.concat + [ "&", T.decodeUtf8 name + , " #", T.decodeUtf8 transaction + , " @", T.pack (show addr) + ] + {----------------------------------------------------------------------- -- Client -----------------------------------------------------------------------} @@ -189,9 +199,7 @@ query addr params = do Manager {..} <- getManager tid <- liftIO $ genTransactionId transactionCounter let queryMethod = method :: Method a b - let signature = T.pack (show queryMethod) - <> " @" <> T.pack (show addr) - <> " #" <> T.decodeUtf8 tid + let signature = querySignature (methodName queryMethod) tid addr $(logDebugS) "query.sending" signature mres <- liftIO $ do @@ -233,12 +241,28 @@ handler body = (name, wrapper) r <- body addr a return $ Right $ toBEncode r -runHandler :: MonadKRPC h m => HandlerBody h -> SockAddr -> KQuery -> m KResult +runHandler :: MonadKRPC h m + => HandlerBody h -> SockAddr -> KQuery -> m KResult runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback where - wrapper = ((`decodeError` queryId) +++ (`KResponse` queryId)) - <$> liftHandler (h addr queryArgs) - failback e = return $ Left $ serverError e queryId + signature = querySignature queryMethod queryId addr + + wrapper = do + $(logDebugS) "handler.quered" signature + result <- liftHandler (h addr queryArgs) + + case result of + Left msg -> do + $(logDebugS) "handler.failed" $ signature <> " !" <> T.pack msg + return $ Left $ decodeError msg queryId + + Right a -> do + $(logDebugS) "handler.success" signature + return $ Right $ a `KResponse` queryId + + failback e = do + $(logDebugS) "handler.errored" signature + return $ Left $ serverError e queryId dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult dispatchHandler q @ KQuery {..} addr = do -- cgit v1.2.3 From 2812bdadb55e1ca7a1e5685f3fb2dafe19259970 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 02:33:46 +0400 Subject: Ignore EOF exception at recvFrom call --- src/Network/KRPC/Manager.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index ee336a4d..4d1cfb69 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -40,6 +40,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Data.BEncode as BE +import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL import Data.IORef @@ -53,6 +54,7 @@ import Network.KRPC.Message import Network.KRPC.Method import Network.Socket hiding (listen) import Network.Socket.ByteString as BS +import System.IO.Error import System.Timeout @@ -303,10 +305,17 @@ listener :: MonadKRPC h m => m () listener = do Manager {..} <- getManager forever $ do - (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize + (bs, addr) <- liftIO $ handle exceptions $ BS.recvFrom sock maxMsgSize case BE.decode bs of - Left e -> liftIO $ sendMessage sock addr $ unknownMessage e + -- TODO ignore unknown messages at all? + Left e -> liftIO $ sendMessage sock addr $ unknownMessage e Right m -> handleMessage m addr + where + exceptions :: IOError -> IO (BS.ByteString, SockAddr) + exceptions e + -- packets with empty payload may trigger eof exception + | isEOFError e = return ("", SockAddrInet 0 0) + | otherwise = throwIO e -- | Should be run before any 'query', otherwise they will never -- succeed. -- cgit v1.2.3 From 6e77e14e2c011760eccc9d6989cd229420bdc741 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 03:53:05 +0400 Subject: Allow to pass options from outside --- bench/Main.hs | 2 +- krpc.cabal | 1 + src/Network/KRPC.hs | 3 +++ src/Network/KRPC/Manager.hs | 60 +++++++++++++++++++++++++++++++++++---------- tests/Network/KRPCSpec.hs | 7 ++++-- 5 files changed, 57 insertions(+), 16 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 13727ff9..8466f4a3 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -22,7 +22,7 @@ addr :: SockAddr addr = SockAddrInet 6000 (256 * 256 * 256 + 127) main :: IO () -main = withManager addr [echo] $ \ m -> (`runReaderT` m) $ do +main = withManager def addr [echo] $ \ m -> (`runReaderT` m) $ do listen liftIO $ defaultMain (benchmarks m) where diff --git a/krpc.cabal b/krpc.cabal index b5004026..be19775f 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -46,6 +46,7 @@ library build-depends: base == 4.* , bytestring >= 0.10 , text >= 0.11 + , data-default-class , lifted-base >= 0.1.1 , transformers >= 0.2 , mtl diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index a1767161..7c02702c 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -62,6 +62,8 @@ module Network.KRPC -- * Manager , MonadKRPC (..) + , Options (..) + , def , Manager , newManager , closeManager @@ -76,6 +78,7 @@ module Network.KRPC , SockAddr (..) ) where +import Data.Default.Class import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 4d1cfb69..7edcf72d 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -18,6 +18,7 @@ module Network.KRPC.Manager ( -- * Manager MonadKRPC (..) + , Options (..) , Manager , newManager , closeManager @@ -43,6 +44,7 @@ import Data.BEncode as BE import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL +import Data.Default.Class import Data.IORef import Data.List as L import Data.Map as M @@ -58,6 +60,41 @@ import System.IO.Error import System.Timeout +{----------------------------------------------------------------------- +-- Options +-----------------------------------------------------------------------} + +-- | RPC manager options. +data Options = Options + { -- | Initial 'TransactionId' incremented with each 'query'; + optSeedTransaction :: Int + + -- | Time to wait for response from remote node, in seconds. + , optQueryTimeout :: Int + } deriving (Show, Eq) + +defaultSeedTransaction :: Int +defaultSeedTransaction = 0 + +defaultQueryTimeout :: Int +defaultQueryTimeout = 120 + +-- | Permissive defaults. +instance Default Options where + def = Options + { optSeedTransaction = defaultSeedTransaction + , optQueryTimeout = defaultQueryTimeout + } + +validateOptions :: Options -> IO () +validateOptions Options {..} + | optQueryTimeout < 1 = throwIO (userError "non-positive query timeout") + | otherwise = return () + +{----------------------------------------------------------------------- +-- Options +-----------------------------------------------------------------------} + type KResult = Either KError KResponse type TransactionCounter = IORef Int @@ -108,23 +145,19 @@ sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX -seedTransaction :: Int -seedTransaction = 0 - -defaultQueryTimeout :: Int -defaultQueryTimeout = 120 - -- | Bind socket to the specified address. To enable query handling -- run 'listen'. -newManager :: SockAddr -- ^ address to listen on; +newManager :: Options -- ^ various protocol options; + -> SockAddr -- ^ address to listen on; -> [Handler h] -- ^ handlers to run on incoming queries. - -> IO (Manager h) -- ^ new manager. -newManager servAddr handlers = do + -> IO (Manager h) -- ^ new rpc manager. +newManager opts @ Options {..} servAddr handlers = do + validateOptions opts sock <- bindServ tref <- newEmptyMVar - tran <- newIORef seedTransaction + tran <- newIORef optSeedTransaction calls <- newIORef M.empty - return $ Manager sock defaultQueryTimeout tref tran calls handlers + return $ Manager sock optQueryTimeout tref tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -143,8 +176,9 @@ closeManager Manager {..} = do -- | Normally you should use Control.Monad.Trans.Resource.allocate -- function. -withManager :: SockAddr -> [Handler h] -> (Manager h -> IO a) -> IO a -withManager addr hs = bracket (newManager addr hs) closeManager +withManager :: Options -> SockAddr -> [Handler h] + -> (Manager h -> IO a) -> IO a +withManager opts addr hs = bracket (newManager opts addr hs) closeManager {----------------------------------------------------------------------- -- Logging diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 7f5b2794..e73b1ec0 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -20,18 +20,21 @@ handlers = instance MonadLogger IO where monadLoggerLog _ _ _ _ = return () +opts :: Options +opts = def { optQueryTimeout = 1 } + spec :: Spec spec = do describe "query" $ do it "run handlers" $ do let int = 0xabcd :: Int - (withManager servAddr handlers $ runReaderT $ do + (withManager opts servAddr handlers $ runReaderT $ do listen query servAddr (Echo int)) `shouldReturn` Echo int it "throw timeout exception" $ do - (withManager servAddr handlers $ runReaderT $ do + (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) ) `shouldThrow` (== KError GenericError "timeout expired" "0") -- cgit v1.2.3 From 018afe46b911c14472cf1a8cf315912e5c687e04 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 04:18:50 +0400 Subject: Fix listenerThread mvar state tracking --- src/Network/KRPC/Manager.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 7edcf72d..d561d7b1 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -35,7 +35,7 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Lifted (fork) import Control.Exception hiding (Handler) -import Control.Exception.Lifted as Lifted (catch) +import Control.Exception.Lifted as Lifted (catch, finally) import Control.Monad import Control.Monad.Logger import Control.Monad.Reader @@ -332,6 +332,7 @@ handleMessage (Q q) = handleQuery q handleMessage (R r) = handleResponse (Right r) handleMessage (E e) = handleResponse (Left e) +-- TODO to options maxMsgSize :: Int maxMsgSize = 64 * 1024 @@ -356,5 +357,7 @@ listener = do listen :: MonadKRPC h m => m () listen = do Manager {..} <- getManager - tid <- fork $ listener + tid <- fork $ do + listener `Lifted.finally` + liftIO (takeMVar listenerThread) liftIO $ putMVar listenerThread tid -- cgit v1.2.3 From a9a0be92f7db16e1d7afe3422e56b7d7d2a63ec9 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Tue, 7 Jan 2014 04:38:02 +0400 Subject: Allow to configure max buffer size --- src/Network/KRPC/Manager.hs | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index d561d7b1..bf142738 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -67,10 +67,13 @@ import System.Timeout -- | RPC manager options. data Options = Options { -- | Initial 'TransactionId' incremented with each 'query'; - optSeedTransaction :: Int + optSeedTransaction :: {-# UNPACK #-} !Int -- | Time to wait for response from remote node, in seconds. - , optQueryTimeout :: Int + , optQueryTimeout :: {-# UNPACK #-} !Int + + -- | Maximum number of bytes to receive. + , optMaxMsgSize :: {-# UNPACK #-} !Int } deriving (Show, Eq) defaultSeedTransaction :: Int @@ -79,16 +82,23 @@ defaultSeedTransaction = 0 defaultQueryTimeout :: Int defaultQueryTimeout = 120 +defaultMaxMsgSize :: Int +defaultMaxMsgSize = 64 * 1024 + -- | Permissive defaults. instance Default Options where def = Options { optSeedTransaction = defaultSeedTransaction , optQueryTimeout = defaultQueryTimeout + , optMaxMsgSize = defaultMaxMsgSize } validateOptions :: Options -> IO () validateOptions Options {..} - | optQueryTimeout < 1 = throwIO (userError "non-positive query timeout") + | optQueryTimeout < 1 + = throwIO (userError "krpc: non-positive query timeout") + | optMaxMsgSize < 1 + = throwIO (userError "krpc: non-positive buffer size") | otherwise = return () {----------------------------------------------------------------------- @@ -112,7 +122,7 @@ type Handler h = (MethodName, HandlerBody h) -- made by /remote/ nodes. data Manager h = Manager { sock :: !Socket - , queryTimeout :: !Int -- ^ in seconds + , options :: !Options , listenerThread :: !(MVar ThreadId) , transactionCounter :: {-# UNPACK #-} !TransactionCounter , pendingCalls :: {-# UNPACK #-} !PendingCalls @@ -157,7 +167,7 @@ newManager opts @ Options {..} servAddr handlers = do tref <- newEmptyMVar tran <- newIORef optSeedTransaction calls <- newIORef M.empty - return $ Manager sock optQueryTimeout tref tran calls handlers + return $ Manager sock opts tref tran calls handlers where bindServ = do let family = sockAddrFamily servAddr @@ -245,7 +255,7 @@ query addr params = do sendMessage sock addr q `onException` unregisterQuery (tid, addr) pendingCalls - timeout (queryTimeout * 10 ^ (6 :: Int)) $ do + timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do queryResponse ares case mres of @@ -255,8 +265,8 @@ query addr params = do Nothing -> do _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls - $(logWarnS) "query.not_responding" $ signature - <> " for " <> T.pack (show queryTimeout) <> " seconds" + $(logWarnS) "query.not_responding" $ signature <> " for " <> + T.pack (show (optQueryTimeout options)) <> " seconds" throw $ timeoutExpired tid {----------------------------------------------------------------------- @@ -332,15 +342,13 @@ handleMessage (Q q) = handleQuery q handleMessage (R r) = handleResponse (Right r) handleMessage (E e) = handleResponse (Left e) --- TODO to options -maxMsgSize :: Int -maxMsgSize = 64 * 1024 - listener :: MonadKRPC h m => m () listener = do Manager {..} <- getManager forever $ do - (bs, addr) <- liftIO $ handle exceptions $ BS.recvFrom sock maxMsgSize + (bs, addr) <- liftIO $ do + handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) + case BE.decode bs of -- TODO ignore unknown messages at all? Left e -> liftIO $ sendMessage sock addr $ unknownMessage e -- cgit v1.2.3 From fe87b6cec9504114dafca26166b51f6c48250106 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 02:46:32 +0400 Subject: Introduce QueryFailure exceptions --- src/Network/KRPC.hs | 3 +++ src/Network/KRPC/Manager.hs | 30 +++++++++++++++++++++++------- 2 files changed, 26 insertions(+), 7 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 7c02702c..96971803 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -58,6 +58,9 @@ module Network.KRPC -- * RPC , Handler , handler + + -- ** Query + , QueryFailure (..) , query -- * Manager diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index bf142738..6799277f 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -14,6 +14,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} module Network.KRPC.Manager ( -- * Manager @@ -26,7 +27,10 @@ module Network.KRPC.Manager , listen -- * Queries + , QueryFailure (..) , query + + -- * Handlers , Handler , handler ) where @@ -52,6 +56,7 @@ import Data.Monoid import Data.Text as T import Data.Text.Encoding as T import Data.Tuple +import Data.Typeable import Network.KRPC.Message import Network.KRPC.Method import Network.Socket hiding (listen) @@ -204,6 +209,15 @@ querySignature name transaction addr = T.concat {----------------------------------------------------------------------- -- Client -----------------------------------------------------------------------} +-- we don't need to know about TransactionId while performing query, +-- so we introduce QueryFailure exceptions + +data QueryFailure + = QueryFailed ErrorCode Text + | TimeoutExpired + deriving (Show, Eq, Typeable) + +instance Exception QueryFailure sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () sendMessage sock addr a = do @@ -230,15 +244,17 @@ unregisterQuery cid ref = do queryResponse :: BEncode a => CallRes -> IO a queryResponse ares = do res <- readMVar ares - KResponse {..} <- either throwIO pure res - case fromBEncode respVals of - Right r -> pure r - Left e -> throwIO $ decodeError e respId + case res of + Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m) + Right (KResponse {..}) -> + case fromBEncode respVals of + Right r -> pure r + Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) -- | Enqueue query to the given node. -- --- This function will throw exception if quered node respond with --- @error@ message or timeout expires. +-- This function should throw 'QueryFailure' exception if quered node +-- respond with @error@ message or the query timeout expires. -- query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b query addr params = do @@ -267,7 +283,7 @@ query addr params = do _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls $(logWarnS) "query.not_responding" $ signature <> " for " <> T.pack (show (optQueryTimeout options)) <> " seconds" - throw $ timeoutExpired tid + throw $ TimeoutExpired {----------------------------------------------------------------------- -- Handlers -- cgit v1.2.3 From 6f909c0d81d04b997f8c81ec1ac05e94d7d1e5b6 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 06:26:35 +0400 Subject: Add HandlerFailure exceptions --- src/Network/KRPC.hs | 13 +++++----- src/Network/KRPC/Manager.hs | 60 ++++++++++++++++++++++++++++++++++++++------- src/Network/KRPC/Message.hs | 17 ------------- tests/Network/KRPCSpec.hs | 2 +- 4 files changed, 58 insertions(+), 34 deletions(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 96971803..69a4efca 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -56,13 +56,15 @@ module Network.KRPC , KRPC (..) -- * RPC - , Handler - , handler - -- ** Query , QueryFailure (..) , query + -- ** Handler + , HandlerFailure (..) + , Handler + , handler + -- * Manager , MonadKRPC (..) , Options (..) @@ -73,11 +75,8 @@ module Network.KRPC , withManager , listen - -- * Exceptions - , KError (..) + -- * Re-expor , ErrorCode (..) - - -- * Re-export , SockAddr (..) ) where diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 6799277f..222b961a 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -31,6 +31,7 @@ module Network.KRPC.Manager , query -- * Handlers + , HandlerFailure (..) , Handler , handler ) where @@ -39,7 +40,8 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Lifted (fork) import Control.Exception hiding (Handler) -import Control.Exception.Lifted as Lifted (catch, finally) +import qualified Control.Exception.Lifted as E (Handler (..)) +import Control.Exception.Lifted as Lifted (catches, finally) import Control.Monad import Control.Monad.Logger import Control.Monad.Reader @@ -288,9 +290,38 @@ query addr params = do {----------------------------------------------------------------------- -- Handlers -----------------------------------------------------------------------} +-- we already throw: +-- +-- * ErrorCode(MethodUnknown) in the 'dispatchHandler'; +-- +-- * ErrorCode(ServerError) in the 'runHandler'; (those can be +-- async exception too) +-- +-- * ErrorCode(GenericError) on + +-- | Used to signal protocol errors. +data HandlerFailure + = BadAddress -- ^ for e.g.: node calls herself; + | InvalidParameter Text -- ^ for e.g.: bad session token. + deriving (Show, Eq, Typeable) + +instance Exception HandlerFailure + +prettyHF :: HandlerFailure -> BS.ByteString +prettyHF BadAddress = T.encodeUtf8 "bad address" +prettyHF (InvalidParameter reason) = T.encodeUtf8 $ + "invalid parameter: " <> reason + +prettyQF :: QueryFailure -> BS.ByteString +prettyQF e = T.encodeUtf8 $ "handler fail while performing query: " + <> T.pack (show e) -- | Make handler from handler function. Any thrown exception will be -- supressed and send over the wire back to the querying node. +-- +-- If the handler make some 'query' normally it /should/ handle +-- corresponding 'QueryFailure's. +-- handler :: forall h a b. (KRPC a b, Monad h) => (SockAddr -> a -> h b) -> Handler h handler body = (name, wrapper) @@ -305,7 +336,7 @@ handler body = (name, wrapper) runHandler :: MonadKRPC h m => HandlerBody h -> SockAddr -> KQuery -> m KResult -runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback +runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks where signature = querySignature queryMethod queryId addr @@ -315,22 +346,33 @@ runHandler h addr KQuery {..} = wrapper `Lifted.catch` failback case result of Left msg -> do - $(logDebugS) "handler.failed" $ signature <> " !" <> T.pack msg - return $ Left $ decodeError msg queryId + $(logDebugS) "handler.bad_query" $ signature <> " !" <> T.pack msg + return $ Left $ KError ProtocolError (BC.pack msg) queryId Right a -> do $(logDebugS) "handler.success" signature - return $ Right $ a `KResponse` queryId + return $ Right $ KResponse a queryId + + failbacks = + [ E.Handler $ \ (e :: HandlerFailure) -> do + $(logDebugS) "handler.failed" signature + return $ Left $ KError ProtocolError (prettyHF e) queryId + + -- may happen if handler makes query and fail + , E.Handler $ \ (e :: QueryFailure) -> do + return $ Left $ KError ServerError (prettyQF e) queryId - failback e = do - $(logDebugS) "handler.errored" signature - return $ Left $ serverError e queryId + -- since handler thread exit after sendMessage we can safely + -- suppress async exception here + , E.Handler $ \ (e :: SomeException) -> do + return $ Left $ KError GenericError (BC.pack (show e)) queryId + ] dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult dispatchHandler q @ KQuery {..} addr = do Manager {..} <- getManager case L.lookup queryMethod handlers of - Nothing -> return $ Left $ unknownMethod queryMethod queryId + Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId Just h -> runHandler h addr q {----------------------------------------------------------------------- diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index d6279f11..96945843 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -26,11 +26,8 @@ module Network.KRPC.Message -- * Error , ErrorCode (..) , KError(..) - , serverError , decodeError - , unknownMethod , unknownMessage - , timeoutExpired -- * Query , KQuery(..) @@ -143,29 +140,15 @@ instance BEncode KError where instance Exception KError --- | Happen when some query handler fail. -serverError :: SomeException -> TransactionId -> KError -serverError e = KError ServerError (BC.pack (show e)) - -- | Received 'queryArgs' or 'respVals' can not be decoded. decodeError :: String -> TransactionId -> KError decodeError msg = KError ProtocolError (BC.pack msg) --- | If /remote/ node send query /this/ node doesn't know about then --- this error message should be sent in response. -unknownMethod :: MethodName -> TransactionId -> KError -unknownMethod = KError MethodUnknown - -- | A remote node has send some 'KMessage' this node is unable to -- decode. unknownMessage :: String -> KError unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction --- | A /remote/ node is not responding to the /our/ request the for --- specified period of time. -timeoutExpired :: TransactionId -> KError -timeoutExpired = KError GenericError "timeout expired" - {----------------------------------------------------------------------- -- Query messages -----------------------------------------------------------------------} diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index e73b1ec0..756c6855 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -37,4 +37,4 @@ spec = do (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) ) - `shouldThrow` (== KError GenericError "timeout expired" "0") + `shouldThrow` (== TimeoutExpired) -- cgit v1.2.3 From e26ef0001157a1ff6b3a1ec809e5c53c37472161 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 06:48:34 +0400 Subject: Handle sendmsg failures --- src/Network/KRPC/Manager.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 222b961a..468744c1 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -214,9 +214,11 @@ querySignature name transaction addr = T.concat -- we don't need to know about TransactionId while performing query, -- so we introduce QueryFailure exceptions +-- | Used to signal 'query' errors. data QueryFailure - = QueryFailed ErrorCode Text - | TimeoutExpired + = SendFailed -- ^ unable to send query; + | QueryFailed ErrorCode Text -- ^ remote node return error; + | TimeoutExpired -- ^ remote node not responding. deriving (Show, Eq, Typeable) instance Exception QueryFailure @@ -253,6 +255,13 @@ queryResponse ares = do Right r -> pure r Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) +-- (sendmsg EINVAL) +sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO () +sendQuery sock addr q = handle sockError $ sendMessage sock addr q + where + sockError :: IOError -> IO () + sockError _ = throwIO SendFailed + -- | Enqueue query to the given node. -- -- This function should throw 'QueryFailure' exception if quered node @@ -270,7 +279,7 @@ query addr params = do ares <- registerQuery (tid, addr) pendingCalls let q = KQuery (toBEncode params) (methodName queryMethod) tid - sendMessage sock addr q + sendQuery sock addr q `onException` unregisterQuery (tid, addr) pendingCalls timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do -- cgit v1.2.3 From 1fb619d9d5edc1c352e2b72cbf5dfcf5c64d05ff Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 06:56:28 +0400 Subject: Allow to ask for query count --- src/Network/KRPC.hs | 1 + src/Network/KRPC/Manager.hs | 8 ++++++++ tests/Network/KRPCSpec.hs | 9 +++++++++ 3 files changed, 18 insertions(+) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 69a4efca..3b722ac2 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -59,6 +59,7 @@ module Network.KRPC -- ** Query , QueryFailure (..) , query + , getQueryCount -- ** Handler , HandlerFailure (..) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 468744c1..e2b60b6a 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -29,6 +29,7 @@ module Network.KRPC.Manager -- * Queries , QueryFailure (..) , query + , getQueryCount -- * Handlers , HandlerFailure (..) @@ -232,6 +233,13 @@ genTransactionId ref = do cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur) return $ BC.pack (show cur) +-- | How many times 'query' call have been performed. +getQueryCount :: MonadKRPC h m => m Int +getQueryCount = do + Manager {..} <- getManager + curTrans <- liftIO $ readIORef transactionCounter + return $ curTrans - optSeedTransaction options + registerQuery :: CallId -> PendingCalls -> IO CallRes registerQuery cid ref = do ares <- newEmptyMVar diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 756c6855..e695a646 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -33,6 +33,15 @@ spec = do query servAddr (Echo int)) `shouldReturn` Echo int + it "count transactions properly" $ do + (withManager opts servAddr handlers $ runReaderT $ do + listen + _ <- query servAddr (Echo (0xabcd :: Int)) + _ <- query servAddr (Echo (0xabcd :: Int)) + getQueryCount + ) + `shouldReturn` 2 + it "throw timeout exception" $ do (withManager opts servAddr handlers $ runReaderT $ do query servAddr (Echo (0xabcd :: Int)) -- cgit v1.2.3 From 73ce8f14a938326975050691042b93ad5eedca66 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 07:01:19 +0400 Subject: Add some options TODOs --- src/Network/KRPC/Manager.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index e2b60b6a..22bfe477 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -202,6 +202,7 @@ withManager opts addr hs = bracket (newManager opts addr hs) closeManager -- Logging -----------------------------------------------------------------------} +-- TODO prettify log messages querySignature :: MethodName -> TransactionId -> SockAddr -> Text querySignature name transaction addr = T.concat [ "&", T.decodeUtf8 name @@ -311,10 +312,12 @@ query addr params = do -- -- * ErrorCode(MethodUnknown) in the 'dispatchHandler'; -- --- * ErrorCode(ServerError) in the 'runHandler'; (those can be +-- * ErrorCode(ServerError) in the 'runHandler'; +-- +-- * ErrorCode(GenericError) in the 'runHandler' (those can be -- async exception too) -- --- * ErrorCode(GenericError) on +-- so HandlerFailure should cover *only* 'ProtocolError's. -- | Used to signal protocol errors. data HandlerFailure @@ -396,6 +399,13 @@ dispatchHandler q @ KQuery {..} addr = do -- Listener -----------------------------------------------------------------------} +-- TODO bound amount of parallel handler *threads*: +-- +-- peer A flooding with find_node +-- peer B trying to ping peer C +-- peer B fork too many threads +-- ... space leak +-- handleQuery :: MonadKRPC h m => KQuery -> SockAddr -> m () handleQuery q addr = void $ fork $ do Manager {..} <- getManager -- cgit v1.2.3 From d67a7608384153e549041486e5dcdd00f499be51 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 07:03:46 +0400 Subject: Fix typo --- src/Network/KRPC.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 3b722ac2..bb7f7127 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -76,7 +76,7 @@ module Network.KRPC , withManager , listen - -- * Re-expor + -- * Re-exports , ErrorCode (..) , SockAddr (..) ) where -- cgit v1.2.3 From 41ca2fc6ece3e24542703035c4249f409eca3906 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 8 Jan 2014 07:11:37 +0400 Subject: Bump version number --- ChangeLog | 11 +++++++++++ krpc.cabal | 6 +++--- src/Network/KRPC.hs | 2 +- src/Network/KRPC/Manager.hs | 2 +- src/Network/KRPC/Message.hs | 2 +- src/Network/KRPC/Method.hs | 2 +- 6 files changed, 18 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index 48a67416..c65825a3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2014-01-08 Sam Truzjan + + 0.6.0.0: Logging + exceptions. + + API changes: + + * MonadLogger is superclass of MonadKRPC; + * KError hidden from Network.KRPC; + * HandlerFailure added; + * QueryFailure and getQueryCount added. + 2013-12-25 Sam Truzjan 0.5.0.0: Major API changes. diff --git a/krpc.cabal b/krpc.cabal index be19775f..fc350367 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,10 +1,10 @@ name: krpc -version: 0.5.0.0 +version: 0.6.0.0 license: BSD3 license-file: LICENSE author: Sam Truzjan maintainer: Sam Truzjan -copyright: (c) 2013, Sam Truzjan +copyright: (c) 2013-2014 Sam Truzjan category: Network build-type: Simple cabal-version: >= 1.10 @@ -32,7 +32,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.5.0.0 + tag: v0.6.0.0 library default-language: Haskell2010 diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index bb7f7127..f7b8378a 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -1,5 +1,5 @@ -- | --- Copyright : (c) Sam Truzjan 2013 +-- Copyright : (c) Sam Truzjan 2013, 2014 -- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 22bfe477..e0ea9618 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -1,5 +1,5 @@ -- | --- Copyright : (c) Sam Truzjan 2013 +-- Copyright : (c) Sam Truzjan 2013, 2014 -- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index 96945843..ebf5573e 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -1,5 +1,5 @@ -- | --- Copyright : (c) Sam Truzjan 2013 +-- Copyright : (c) Sam Truzjan 2013, 2014 -- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index 68f1fa4e..10f988b8 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -1,5 +1,5 @@ -- | --- Copyright : (c) Sam Truzjan 2013 +-- Copyright : (c) Sam Truzjan 2013, 2014 -- License : BSD3 -- Maintainer : pxqr.sta@gmail.com -- Stability : experimental -- cgit v1.2.3 From 9dda7109e1877821612488602cbea3014a3e8566 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 19 Feb 2014 05:16:09 +0400 Subject: Add function isActive --- src/Network/KRPC.hs | 1 + src/Network/KRPC/Manager.hs | 7 +++++++ 2 files changed, 8 insertions(+) diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index f7b8378a..b15927cf 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -74,6 +74,7 @@ module Network.KRPC , newManager , closeManager , withManager + , isActive , listen -- * Re-exports diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index e0ea9618..4436a9ba 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -24,6 +24,7 @@ module Network.KRPC.Manager , newManager , closeManager , withManager + , isActive , listen -- * Queries @@ -192,6 +193,12 @@ closeManager Manager {..} = do -- TODO unblock calls close sock +-- | Check if the manager is still active. Manager becomes active +-- until 'closeManager' called. +isActive :: Manager m -> IO Bool +isActive Manager {..} = liftIO $ isBound sock +{-# INLINE isActive #-} + -- | Normally you should use Control.Monad.Trans.Resource.allocate -- function. withManager :: Options -> SockAddr -> [Handler h] -- cgit v1.2.3 From 2cf3882c4b455abba8aebf7c5bc66e3720ca1598 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 19 Feb 2014 05:16:36 +0400 Subject: Add spec for isActive function --- tests/Network/KRPCSpec.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index e695a646..0a6dc8fb 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -25,6 +25,13 @@ opts = def { optQueryTimeout = 1 } spec :: Spec spec = do + describe "manager" $ do + it "is active until closeManager called" $ do + m <- newManager opts servAddr [] + isActive m `shouldReturn` True + closeManager m + isActive m `shouldReturn` False + describe "query" $ do it "run handlers" $ do let int = 0xabcd :: Int -- cgit v1.2.3 From 81ecdc02e48eccfc558b22d0480e759d6bede750 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Wed, 19 Feb 2014 05:22:42 +0400 Subject: Bump version number to 0.6.1.0 --- ChangeLog | 10 ++++++++++ krpc.cabal | 4 ++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index c65825a3..a4de3c30 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2014-02-19 Sam Truzjan + + 0.6.0.0 + + API changes: + + * Added isActive: this predicate can be used to implement + MonadActive instance and useful for resource + initialization/finalization sanity check. + 2014-01-08 Sam Truzjan 0.6.0.0: Logging + exceptions. diff --git a/krpc.cabal b/krpc.cabal index fc350367..c565bd2a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -1,5 +1,5 @@ name: krpc -version: 0.6.0.0 +version: 0.6.1.0 license: BSD3 license-file: LICENSE author: Sam Truzjan @@ -32,7 +32,7 @@ source-repository this type: git location: git://github.com/cobit/krpc.git branch: master - tag: v0.6.0.0 + tag: v0.6.1.0 library default-language: Haskell2010 -- cgit v1.2.3 From c0e2b270e16a56471bcb00c7772c06945357b5eb Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 15 Mar 2014 19:05:40 +0400 Subject: Update TODO --- TODO.org | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/TODO.org b/TODO.org index 19904f73..dbba5c8c 100644 --- a/TODO.org +++ b/TODO.org @@ -1,17 +1,17 @@ -* DONE document protocol -* DONE Ascending everywhere -* DONE document KRPC module -* DONE move exsamples to tests -* DONE make HUnit tests -* DONE run server in test automatically -* DONE use one socket everywhere -* DONE fix performance issues -* DONE add readme -* DONE return scheme back -* DONE add Show instance for Method -* DONE add BEncodable instance for Method -* DONE remove async api -* DONE expose client addr in server-side handlers -* DONE major version bump to 0.2.0.0 (reason: async API removed) -* DONE Remote.* -> Network.* -* DONE ipv6 support +* configure travis +* liftKRPC :: +* add withRetries +* bump version to 0.7.0.0 + +* add issue: getQueryCount --> getRpcStats +data Stats = Stats + { queryFailed :: {-# UNPACK #-} !Int + , querySucceed :: {-# UNPACK #-} !Int + , handlerFailed :: {-# UNPACK #-} !Int + , handlerSucceed :: {-# UNPACK #-} !Int + , sentBytes :: {-# UNPACK #-} !Int + , receivedBytes :: {-# UNPACK #-} !Int + } + +* add asyncQuery :: SockAddr -> a -> m (Async a) +* add queries :: [(SockAddr, a)] -> m [Either a] \ No newline at end of file -- cgit v1.2.3 From 827a57f66a2ea0087d5eae9de75abae27edbce29 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sat, 29 Mar 2014 23:09:07 +0400 Subject: Hide Message, Method, Manager modules --- krpc.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index c565bd2a..20576dd1 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -40,7 +40,7 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Network.KRPC - Network.KRPC.Message + other-modules: Network.KRPC.Message Network.KRPC.Method Network.KRPC.Manager build-depends: base == 4.* -- cgit v1.2.3 From 7843136fb05c71f2a0c8e7cd4980ecf1b951ffbe Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 1 Aug 2014 21:57:18 +0200 Subject: Remove unnecessary FunctionalDependency This fixes cobit/bittorrent#7 for GHC 7.8.3: 7.8.3 fixed FunctionalDependencies so the existing instances are no longer allowed and in fact FD is not necessary there at all. --- src/Network/KRPC/Method.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index 10f988b8..ea9da958 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -9,7 +9,6 @@ -- {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DefaultSignatures #-} @@ -75,7 +74,7 @@ showsMethod (Method name) = -- @ -- class (Typeable req, BEncode req, Typeable resp, BEncode resp) - => KRPC req resp | req -> resp where + => KRPC req resp where -- | Method name. Default implementation uses lowercased @req@ -- datatype name. -- cgit v1.2.3 From 19d9b9887670ad91738a1d5069db10a0f9c6b2a1 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Sun, 3 Aug 2014 01:49:37 +0400 Subject: Revert "Hide Message, Method, Manager modules", fixes #1 This reverts commit 827a57f66a2ea0087d5eae9de75abae27edbce29. --- krpc.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/krpc.cabal b/krpc.cabal index 20576dd1..c565bd2a 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -40,7 +40,7 @@ library , RecordWildCards hs-source-dirs: src exposed-modules: Network.KRPC - other-modules: Network.KRPC.Message + Network.KRPC.Message Network.KRPC.Method Network.KRPC.Manager build-depends: base == 4.* -- cgit v1.2.3 From a70c08ee48908ed7c43e38d529baa641434f2792 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 16 Aug 2014 13:05:31 +0100 Subject: Convenient GHCi settings --- .ghci | 1 + 1 file changed, 1 insertion(+) diff --git a/.ghci b/.ghci index 0c692119..829e5e3d 100644 --- a/.ghci +++ b/.ghci @@ -1,3 +1,4 @@ +:set -isrc -itests -XRecordWildCards import Control.Concurrent import Data.BEncode import Network -- cgit v1.2.3 From 4ebd950f3f61dcc7f8287a3f9d1dcf44b9bfeac8 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 16 Aug 2014 13:10:38 +0100 Subject: Disambiguate KRPC instance inside spec --- tests/Network/KRPCSpec.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tests/Network/KRPCSpec.hs b/tests/Network/KRPCSpec.hs index 0a6dc8fb..eabcc817 100644 --- a/tests/Network/KRPCSpec.hs +++ b/tests/Network/KRPCSpec.hs @@ -25,6 +25,9 @@ opts = def { optQueryTimeout = 1 } spec :: Spec spec = do + let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int) + qr = query + describe "manager" $ do it "is active until closeManager called" $ do m <- newManager opts servAddr [] @@ -43,14 +46,14 @@ spec = do it "count transactions properly" $ do (withManager opts servAddr handlers $ runReaderT $ do listen - _ <- query servAddr (Echo (0xabcd :: Int)) - _ <- query servAddr (Echo (0xabcd :: Int)) + _ <- qr servAddr (Echo 0xabcd) + _ <- qr servAddr (Echo 0xabcd) getQueryCount ) `shouldReturn` 2 it "throw timeout exception" $ do (withManager opts servAddr handlers $ runReaderT $ do - query servAddr (Echo (0xabcd :: Int)) + qr servAddr (Echo 0xabcd) ) `shouldThrow` (== TimeoutExpired) -- cgit v1.2.3 From 5d0791e6ed2e500c08e7dadda39a254c8340cef5 Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 17 Jan 2017 18:42:09 -0500 Subject: Handle reflected IP addresses (see bep 42). --- krpc.cabal | 14 +++++++-- src/Network/KRPC.hs | 4 ++- src/Network/KRPC/Manager.hs | 61 ++++++++++++++++++++++++--------------- src/Network/KRPC/Message.hs | 45 ++++++++++++++++++++++++++--- src/Network/KRPC/Method.hs | 3 +- tests/Network/KRPC/MessageSpec.hs | 7 +++-- 6 files changed, 99 insertions(+), 35 deletions(-) diff --git a/krpc.cabal b/krpc.cabal index c565bd2a..66c08ccb 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -34,6 +34,11 @@ source-repository this branch: master tag: v0.6.1.0 +flag builder + description: Use older bytestring package and bytestring-builder. + default: False + + library default-language: Haskell2010 default-extensions: PatternGuards @@ -44,7 +49,6 @@ library Network.KRPC.Method Network.KRPC.Manager build-depends: base == 4.* - , bytestring >= 0.10 , text >= 0.11 , data-default-class , lifted-base >= 0.1.1 @@ -54,7 +58,13 @@ library , monad-logger >= 0.3 , bencoding >= 0.4.3 , network >= 2.3 + , cereal , containers + if flag(builder) + build-depends: bytestring >= 0.9, bytestring-builder + else + build-depends: bytestring >= 0.10 + if impl(ghc < 7.6) build-depends: ghc-prim ghc-options: -Wall @@ -89,4 +99,4 @@ benchmark bench , monad-logger , criterion , krpc - ghc-options: -O2 -fforce-recomp \ No newline at end of file + ghc-options: -O2 -fforce-recomp diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index b15927cf..d185fb4c 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs @@ -59,6 +59,8 @@ module Network.KRPC -- ** Query , QueryFailure (..) , query + , query' + , queryRaw , getQueryCount -- ** Handler @@ -86,4 +88,4 @@ import Data.Default.Class import Network.KRPC.Message import Network.KRPC.Method import Network.KRPC.Manager -import Network.Socket (SockAddr (..)) \ No newline at end of file +import Network.Socket (SockAddr (..)) diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 4436a9ba..9477d23c 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -30,6 +30,8 @@ module Network.KRPC.Manager -- * Queries , QueryFailure (..) , query + , query' + , queryRaw , getQueryCount -- * Handlers @@ -49,6 +51,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control import Data.BEncode as BE +import Data.BEncode.Internal as BE import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL @@ -118,7 +121,7 @@ type KResult = Either KError KResponse type TransactionCounter = IORef Int type CallId = (TransactionId, SockAddr) -type CallRes = MVar KResult +type CallRes = MVar (BValue, KResult) type PendingCalls = IORef (Map CallId CallRes) type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue) @@ -163,6 +166,7 @@ sockAddrFamily :: SockAddr -> Family sockAddrFamily (SockAddrInet _ _ ) = AF_INET sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 sockAddrFamily (SockAddrUnix _ ) = AF_UNIX +sockAddrFamily (SockAddrCan _ ) = AF_CAN -- | Bind socket to the specified address. To enable query handling -- run 'listen'. @@ -261,15 +265,6 @@ unregisterQuery cid ref = do atomicModifyIORef' ref $ swap . M.updateLookupWithKey (const (const Nothing)) cid -queryResponse :: BEncode a => CallRes -> IO a -queryResponse ares = do - res <- readMVar ares - case res of - Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m) - Right (KResponse {..}) -> - case fromBEncode respVals of - Right r -> pure r - Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) -- (sendmsg EINVAL) sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO () @@ -284,7 +279,21 @@ sendQuery sock addr q = handle sockError $ sendMessage sock addr q -- respond with @error@ message or the query timeout expires. -- query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b -query addr params = do +query addr params = queryK addr params (\_ x _ -> x) + +-- | Like 'query' but possibly returns your externally routable IP address. +query' :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, Maybe ReflectedIP) +query' addr params = queryK addr params (const (,)) + +-- | Enqueue a query, but give us the complete BEncoded content sent by the +-- remote Node. This is useful for handling extensions that this library does +-- not otherwise support. +queryRaw :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, BValue) +queryRaw addr params = queryK addr params (\raw x _ -> (x,raw)) + +queryK :: forall h m a b x. (MonadKRPC h m, KRPC a b) => + SockAddr -> a -> (BValue -> b -> Maybe ReflectedIP -> x) -> m x +queryK addr params kont = do Manager {..} <- getManager tid <- liftIO $ genTransactionId transactionCounter let queryMethod = method :: Method a b @@ -299,7 +308,13 @@ query addr params = do `onException` unregisterQuery (tid, addr) pendingCalls timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do - queryResponse ares + (raw,res) <- readMVar ares + case res of + Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m) + Right (KResponse {..}) -> + case fromBEncode respVals of + Right r -> pure $ kont raw r respIP + Left e -> throwIO $ QueryFailed ProtocolError (T.pack e) case mres of Just res -> do @@ -378,7 +393,7 @@ runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks Right a -> do $(logDebugS) "handler.success" signature - return $ Right $ KResponse a queryId + return $ Right $ KResponse a queryId (Just $ ReflectedIP addr) failbacks = [ E.Handler $ \ (e :: HandlerFailure) -> do @@ -419,20 +434,20 @@ handleQuery q addr = void $ fork $ do res <- dispatchHandler q addr sendMessage sock addr $ either toBEncode toBEncode res -handleResponse :: MonadKRPC h m => KResult -> SockAddr -> m () -handleResponse result addr = do +handleResponse :: MonadKRPC h m => BValue -> KResult -> SockAddr -> m () +handleResponse raw result addr = do Manager {..} <- getManager liftIO $ do let resultId = either errorId respId result mcall <- unregisterQuery (resultId, addr) pendingCalls case mcall of Nothing -> return () - Just ares -> putMVar ares result + Just ares -> putMVar ares (raw,result) -handleMessage :: MonadKRPC h m => KMessage -> SockAddr -> m () -handleMessage (Q q) = handleQuery q -handleMessage (R r) = handleResponse (Right r) -handleMessage (E e) = handleResponse (Left e) +handleMessage :: MonadKRPC h m => BValue -> KMessage -> SockAddr -> m () +handleMessage _ (Q q) = handleQuery q +handleMessage raw (R r) = handleResponse raw (Right r) +handleMessage raw (E e) = handleResponse raw (Left e) listener :: MonadKRPC h m => m () listener = do @@ -441,10 +456,10 @@ listener = do (bs, addr) <- liftIO $ do handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) - case BE.decode bs of + case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of -- TODO ignore unknown messages at all? - Left e -> liftIO $ sendMessage sock addr $ unknownMessage e - Right m -> handleMessage m addr + Left e -> liftIO $ sendMessage sock addr $ unknownMessage e + Right (raw,m) -> handleMessage raw m addr where exceptions :: IOError -> IO (BS.ByteString, SockAddr) exceptions e diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs index ebf5573e..6f4ae620 100644 --- a/src/Network/KRPC/Message.hs +++ b/src/Network/KRPC/Message.hs @@ -35,17 +35,22 @@ module Network.KRPC.Message -- * Response , KResponse(..) + , ReflectedIP(..) -- * Message , KMessage (..) ) where import Control.Applicative +import Control.Arrow import Control.Exception.Lifted as Lifted import Data.BEncode as BE import Data.ByteString as B import Data.ByteString.Char8 as BC +import qualified Data.Serialize as S +import Data.Word import Data.Typeable +import Network.Socket (SockAddr (..),PortNumber,HostAddress) -- | This transaction ID is generated by the querying node and is @@ -188,6 +193,35 @@ instance BEncode KQuery where KQuery <$>! "a" <*>! "q" <*>! "t" {-# INLINE fromBEncode #-} +newtype ReflectedIP = ReflectedIP SockAddr + deriving (Eq, Ord, Show) + +instance BEncode ReflectedIP where + toBEncode (ReflectedIP addr) = BString (encodeAddr addr) + fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs + fromBEncode _ = Left "ReflectedIP should be a bencoded string" + +port16 :: Word16 -> PortNumber +port16 = fromIntegral + +decodeAddr :: ByteString -> Either String SockAddr +decodeAddr bs | B.length bs == 6 + = ( \(a,p) -> SockAddrInet <$> fmap port16 p <*> a ) + $ (S.runGet S.getWord32host *** S.decode ) + $ B.splitAt 4 bs +decodeAddr bs | B.length bs == 18 + = ( \(a,p) -> flip SockAddrInet6 0 <$> fmap port16 p <*> a <*> pure 0 ) + $ (S.decode *** S.decode ) + $ B.splitAt 16 bs +decodeAddr _ = Left "incorrectly sized address and port" + +encodeAddr :: SockAddr -> ByteString +encodeAddr (SockAddrInet port addr) + = S.runPut (S.putWord32host addr >> S.put (fromIntegral port :: Word16)) +encodeAddr (SockAddrInet6 port _ addr _) + = S.runPut (S.put addr >> S.put (fromIntegral port :: Word16)) +encodeAddr _ = B.empty + {----------------------------------------------------------------------- -- Response messages -----------------------------------------------------------------------} @@ -206,7 +240,8 @@ instance BEncode KQuery where data KResponse = KResponse { respVals :: BValue -- ^ 'BDict' containing return values; , respId :: TransactionId -- ^ match to the corresponding 'queryId'. - } deriving (Show, Read, Eq, Ord, Typeable) + , respIP :: Maybe ReflectedIP + } deriving (Show, Eq, Ord, Typeable) -- | Responses, or KRPC message dictionaries with a \"y\" value of -- \"r\", contain one additional key \"r\". The value of \"r\" is a @@ -218,7 +253,8 @@ data KResponse = KResponse -- instance BEncode KResponse where toBEncode KResponse {..} = toDict $ - "r" .=! respVals + "ip" .=? respIP + .: "r" .=! respVals .: "t" .=! respId .: "y" .=! ("r" :: ByteString) .: endDict @@ -226,7 +262,8 @@ instance BEncode KResponse where fromBEncode = fromDict $ do lookAhead $ match "y" (BString "r") - KResponse <$>! "r" <*>! "t" + addr <- optional (field (req "ip")) + (\r t -> KResponse r t addr) <$>! "r" <*>! "t" {-# INLINE fromBEncode #-} {----------------------------------------------------------------------- @@ -249,4 +286,4 @@ instance BEncode KMessage where Q <$> fromBEncode b <|> R <$> fromBEncode b <|> E <$> fromBEncode b - <|> decodingError "KMessage: unknown message or message tag" \ No newline at end of file + <|> decodingError "KMessage: unknown message or message tag" diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index ea9da958..916b38a8 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs @@ -47,8 +47,7 @@ newtype Method param result = Method { methodName :: MethodName } instance (Typeable a, Typeable b) => Show (Method a b) where showsPrec _ = showsMethod -showsMethod :: forall a. forall b. Typeable a => Typeable b - => Method a b -> ShowS +showsMethod :: forall a b. ( Typeable a , Typeable b ) => Method a b -> ShowS showsMethod (Method name) = showString (BC.unpack name) <> showString " :: " <> diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs index 7aca4489..498ef679 100644 --- a/tests/Network/KRPC/MessageSpec.hs +++ b/tests/Network/KRPC/MessageSpec.hs @@ -20,7 +20,8 @@ instance Arbitrary KQuery where arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary instance Arbitrary KResponse where - arbitrary = KResponse <$> pure (BList []) <*> arbitrary + -- TODO: Abitrary instance for ReflectedIP + arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing instance Arbitrary KMessage where arbitrary = frequency @@ -64,8 +65,8 @@ spec = do it "properly bencoded" $ do BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe` - Right (KResponse (BList []) "aa") + Right (KResponse (BList []) "aa" Nothing) describe "generic message" $ do it "properly bencoded (iso)" $ property $ \ km -> - BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) \ No newline at end of file + BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage) -- cgit v1.2.3 From a8498921ddf37e864968a3865e3e254352b5d285 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 18 Jan 2017 20:11:36 -0500 Subject: Aeson-based pretty-printing of server requests. --- krpc.cabal | 7 +++++ src/Data/BEncode/Pretty.hs | 75 +++++++++++++++++++++++++++++++++++++++++++++ src/Network/KRPC/Manager.hs | 15 ++++++--- 3 files changed, 93 insertions(+), 4 deletions(-) create mode 100644 src/Data/BEncode/Pretty.hs diff --git a/krpc.cabal b/krpc.cabal index 66c08ccb..452f1132 100644 --- a/krpc.cabal +++ b/krpc.cabal @@ -38,6 +38,9 @@ flag builder description: Use older bytestring package and bytestring-builder. default: False +flag aeson + description: Use aeson for pretty-printing bencoded data. + default: True library default-language: Haskell2010 @@ -48,6 +51,7 @@ library Network.KRPC.Message Network.KRPC.Method Network.KRPC.Manager + Data.BEncode.Pretty build-depends: base == 4.* , text >= 0.11 , data-default-class @@ -60,6 +64,9 @@ library , network >= 2.3 , cereal , containers + if flag(aeson) + build-depends: aeson, aeson-pretty, unordered-containers, vector + ghc-options: -DBENCODE_AESON if flag(builder) build-depends: bytestring >= 0.9, bytestring-builder else diff --git a/src/Data/BEncode/Pretty.hs b/src/Data/BEncode/Pretty.hs new file mode 100644 index 00000000..7b0d46a0 --- /dev/null +++ b/src/Data/BEncode/Pretty.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE CPP #-} +module Data.BEncode.Pretty where -- (showBEncode) where + +import Data.BEncode.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Text (Text) +import qualified Data.Text as T +#ifdef BENCODE_AESON +import Data.BEncode.BDict hiding (map) +import Data.Aeson.Types hiding (parse) +import Data.Aeson.Encode.Pretty +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector +import Data.Foldable as Foldable +import Data.Text.Encoding +import Text.Printf +#endif + +#ifdef BENCODE_AESON + +unhex :: Text -> BS.ByteString +unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2] + where + nibs = encodeUtf8 t + unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10 + + unnib (BS.index nibs (i * 2 + 1)) + unnib a | a <= 0x39 = a - 0x30 + | otherwise = a - (0x41 - 10) + +hex :: BS.ByteString -> Text +hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs + +quote_chr :: Char +quote_chr = ' ' + +quote :: Text -> Text +quote t = quote_chr `T.cons` t `T.snoc` quote_chr + + +instance ToJSON BValue where + toJSON (BInteger x) = Number $ fromIntegral x + toJSON (BString s) = String $ either (const $ hex s) quote $ decodeUtf8' s + toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs + toJSON (BDict d) = toJSON d + +instance ToJSON a => ToJSON (BDictMap a) where + toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d + where + convert (k,v) = (decodeUtf8 k,toJSON v) + +instance FromJSON BValue where + parseJSON (Number x) = pure $ BInteger (truncate x) + parseJSON (Bool x) = pure $ BInteger $ if x then 1 else 0 + parseJSON (String s) + | T.head s==quote_chr = pure $ BString $ encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s) + | otherwise = pure $ BString $ unhex s + parseJSON (Array v) = BList <$> traverse parseJSON (Foldable.toList v) + parseJSON (Object d) = BDict <$> parseJSON (Object d) + parseJSON (Null) = pure $ BDict Nil + +instance FromJSON v => FromJSON (BDictMap v) where + parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d) + where + convert (k,v) = (,) (encodeUtf8 k) <$> parseJSON v + parseJSON _ = fail "Not a BDict" +#endif + +showBEncode :: BValue -> BL.ByteString +#ifdef BENCODE_AESON +showBEncode b = encodePretty $ toJSON b +#else +showBEncode b = BL8.pack (show b) +#endif diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs index 9477d23c..c90c92f9 100644 --- a/src/Network/KRPC/Manager.hs +++ b/src/Network/KRPC/Manager.hs @@ -52,6 +52,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Control import Data.BEncode as BE import Data.BEncode.Internal as BE +import Data.BEncode.Pretty (showBEncode) import Data.ByteString as BS import Data.ByteString.Char8 as BC import Data.ByteString.Lazy as BL @@ -428,11 +429,17 @@ dispatchHandler q @ KQuery {..} addr = do -- peer B fork too many threads -- ... space leak -- -handleQuery :: MonadKRPC h m => KQuery -> SockAddr -> m () -handleQuery q addr = void $ fork $ do +handleQuery :: MonadKRPC h m => BValue -> KQuery -> SockAddr -> m () +handleQuery raw q addr = void $ fork $ do Manager {..} <- getManager res <- dispatchHandler q addr - sendMessage sock addr $ either toBEncode toBEncode res + let resbe = either toBEncode toBEncode res + $(logOther "q") $ T.unlines + [ either (const "") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw) + , "==>" + , either (const "") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe) + ] + sendMessage sock addr resbe handleResponse :: MonadKRPC h m => BValue -> KResult -> SockAddr -> m () handleResponse raw result addr = do @@ -445,7 +452,7 @@ handleResponse raw result addr = do Just ares -> putMVar ares (raw,result) handleMessage :: MonadKRPC h m => BValue -> KMessage -> SockAddr -> m () -handleMessage _ (Q q) = handleQuery q +handleMessage raw (Q q) = handleQuery raw q handleMessage raw (R r) = handleResponse raw (Right r) handleMessage raw (E e) = handleResponse raw (Left e) -- cgit v1.2.3