summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-01-18 21:24:38 -0500
committerjoe <joe@jerkface.net>2017-01-18 21:24:38 -0500
commit1d7dd944e0a13d3f09b65f7629d1f96098ea7974 (patch)
tree6c02f4d9d6e95f9a2d596c1854d5938daeeeddcc
parent3c9e37d4f349ba2b4395cb10b5a3671decf89d68 (diff)
parenta8498921ddf37e864968a3865e3e254352b5d285 (diff)
Merge branch 'krpc' into dht-only
-rw-r--r--ChangeLog94
-rw-r--r--TODO.org17
-rw-r--r--bench/Main.hs37
-rw-r--r--krpc.cabal109
-rw-r--r--src/Data/BEncode/Pretty.hs75
-rw-r--r--src/Network/KRPC.hs91
-rw-r--r--src/Network/KRPC/Manager.hs485
-rw-r--r--src/Network/KRPC/Message.hs289
-rw-r--r--src/Network/KRPC/Method.hs87
-rw-r--r--tests/Network/KRPC/MessageSpec.hs72
-rw-r--r--tests/Network/KRPC/MethodSpec.hs52
-rw-r--r--tests/Network/KRPCSpec.hs59
12 files changed, 1465 insertions, 2 deletions
diff --git a/ChangeLog b/ChangeLog
index c19099a3..60a1006c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,44 @@
12014-02-19 Sam Truzjan <pxqr.sta@gmail.com>
2
3 krpc 0.6.0.0
4
5 API changes:
6
7 * Added isActive: this predicate can be used to implement
8 MonadActive instance and useful for resource
9 initialization/finalization sanity check.
10
112014-01-08 Sam Truzjan <pxqr.sta@gmail.com>
12
13 krpc 0.6.0.0: Logging + exceptions.
14
15 API changes:
16
17 * MonadLogger is superclass of MonadKRPC;
18 * KError hidden from Network.KRPC;
19 * HandlerFailure added;
20 * QueryFailure and getQueryCount added.
21
222013-12-25 Sam Truzjan <pxqr.sta@gmail.com>
23
24 krpc 0.5.0.0: Major API changes.
25
26 * Added transaction handling;
27 * Use the same socket for server and client;
28 * New query function will infer query method from request/response
29 datatypes.
30 * Added MonadKRPC and KRPC classes.
31
322013-11-26 Sam Truzjan <pxqr.sta@gmail.com>
33
34 krpc
35
36 * 0.4.1.1: Fixed build failure on GHC == 7.4.*
37
12013-11-25 Sam Truzjan <pxqr.sta@gmail.com> 382013-11-25 Sam Truzjan <pxqr.sta@gmail.com>
2 39
40 bittorrent
41
3 * Version 0.0.0.3 42 * Version 0.0.0.3
4 * use Pretty class from pretty-class package; 43 * use Pretty class from pretty-class package;
5 * Data.Torrent.Client.hs: 44 * Data.Torrent.Client.hs:
@@ -7,6 +46,8 @@
7 46
82013-11-21 Sam Truzjan <pxqr.sta@gmail.com> 472013-11-21 Sam Truzjan <pxqr.sta@gmail.com>
9 48
49 bittorrent
50
10 Version 0.0.0.2 51 Version 0.0.0.2
11 52
12 * InfoHash.hs: added rendering to Text. 53 * InfoHash.hs: added rendering to Text.
@@ -18,4 +59,57 @@
18 59
192013-11-01 Sam Truzjan <pxqr.sta@gmail.com> 602013-11-01 Sam Truzjan <pxqr.sta@gmail.com>
20 61
62 bittorrent
63
21 Initial version: 0.0.0.1 64 Initial version: 0.0.0.1
65
662013-10-17 Sam Truzjan <pxqr.sta@gmail.com>
67
68 krpc
69
70 * 0.4.1.0: Use bencoding-0.4.*
71
722013-10-03 Sam Truzjan <pxqr.sta@gmail.com>
73
74 krpc
75
76 * 0.4.0.1: Minor documentation fixes.
77
782013-10-03 Sam Truzjan <pxqr.sta@gmail.com>
79
80 krpc
81
82 * 0.4.0.0: IPv6 support.
83
842013-09-28 Sam Truzjan <pxqr.sta@gmail.com>
85
86 krpc
87
88 * 0.3.0.0: Use bencoding-0.3.*
89 * Rename Remote.* to Network.* modules.
90
912013-09-28 Sam Truzjan <pxqr.sta@gmail.com>
92
93 krpc
94
95 * 0.2.2.0: Use bencoding-0.2.2.*
96
972013-08-27 Sam Truzjan <pxqr.sta@gmail.com>
98
99 krpc
100
101 * 0.2.0.0: Async API have been removed, use /async/ package
102 instead.
103 * Expose caller address in handlers.
104
1052013-07-09 Sam Truzjan <pxqr.sta@gmail.com>
106
107 krpc
108
109 * 0.1.1.0: Allow passing raw argument\/result dictionaries.
110
1112013-07-09 Sam Truzjan <pxqr.sta@gmail.com>
112
113 krpc
114
115 * 0.1.0.0: Initial version.
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 00000000..dbba5c8c
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,17 @@
1* configure travis
2* liftKRPC ::
3* add withRetries
4* bump version to 0.7.0.0
5
6* add issue: getQueryCount --> getRpcStats
7data Stats = Stats
8 { queryFailed :: {-# UNPACK #-} !Int
9 , querySucceed :: {-# UNPACK #-} !Int
10 , handlerFailed :: {-# UNPACK #-} !Int
11 , handlerSucceed :: {-# UNPACK #-} !Int
12 , sentBytes :: {-# UNPACK #-} !Int
13 , receivedBytes :: {-# UNPACK #-} !Int
14 }
15
16* add asyncQuery :: SockAddr -> a -> m (Async a)
17* add queries :: [(SockAddr, a)] -> m [Either a] \ No newline at end of file
diff --git a/bench/Main.hs b/bench/Main.hs
index a7b937ff..d021e03e 100644
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -1,14 +1,28 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
1{-# OPTIONS -fno-warn-orphans #-} 3{-# OPTIONS -fno-warn-orphans #-}
2module Main (main) where 4module Main (main) where
3 5
4import Control.DeepSeq 6import Control.DeepSeq
5import Criterion.Main
6import Network 7import Network
8import Control.Monad
9import Control.Monad.Logger
10import Control.Monad.Reader
11import Criterion.Main
12import Data.ByteString as BS
13import Network.KRPC
14
7 15
8import Network.BitTorrent.Exchange.Protocol as BT 16import Network.BitTorrent.Exchange.Protocol as BT
9import Data.Torrent.Block as BT 17import Data.Torrent.Block as BT
10import Data.Torrent.Bitfield as BT 18import Data.Torrent.Bitfield as BT
11 19
20instance KRPC ByteString ByteString where
21 method = "echo"
22
23instance MonadLogger IO where
24 monadLoggerLog _ _ _ _ = return ()
25
12 26
13instance NFData PortNumber where 27instance NFData PortNumber where
14 rnf = rnf . (fromIntegral :: PortNumber -> Int) 28 rnf = rnf . (fromIntegral :: PortNumber -> Int)
@@ -38,5 +52,24 @@ decodeMessages :: ByteString -> Either String [Message]
38decodeMessages = runGet (many get) 52decodeMessages = runGet (many get)
39-} 53-}
40 54
55echo :: Handler IO
56echo = handler $ \ _ bs -> return (bs :: ByteString)
57
58addr :: SockAddr
59addr = SockAddrInet 6000 (256 * 256 * 256 + 127)
60
61-- main :: IO ()
62-- main = defaultMain []
41main :: IO () 63main :: IO ()
42main = defaultMain [] 64main = withManager def addr [echo] $ \ m -> (`runReaderT` m) $ do
65 listen
66 liftIO $ defaultMain (benchmarks m)
67 where
68 sizes = [10, 100, 1000, 10000, 16 * 1024]
69 repetitions = [1, 10, 100, 1000]
70 benchmarks m = [mkbench m r s | r <- repetitions, s <- sizes]
71 where
72 mkbench action r n =
73 bench (show r ++ "times" ++ "/" ++ show n ++ "bytes") $ nfIO $
74 replicateM r $
75 runReaderT (query addr (BS.replicate n 0)) action
diff --git a/krpc.cabal b/krpc.cabal
new file mode 100644
index 00000000..452f1132
--- /dev/null
+++ b/krpc.cabal
@@ -0,0 +1,109 @@
1name: krpc
2version: 0.6.1.0
3license: BSD3
4license-file: LICENSE
5author: Sam Truzjan
6maintainer: Sam Truzjan <pxqr.sta@gmail.com>
7copyright: (c) 2013-2014 Sam Truzjan
8category: Network
9build-type: Simple
10cabal-version: >= 1.10
11tested-with: GHC == 7.4.1
12 , GHC == 7.6.3
13homepage: https://github.com/cobit/krpc
14bug-reports: https://github.com/cobit/krpc/issues
15synopsis: KRPC protocol implementation
16description:
17
18 The KRPC protocol is a simple RPC mechanism consisting of bencoded
19 dictionaries sent over UDP.
20 .
21 <http://bittorrent.org/beps/bep_0005.html#krpc-protocol>
22
23extra-source-files: README.md
24 , ChangeLog
25
26source-repository head
27 type: git
28 location: git://github.com/cobit/krpc.git
29 branch: master
30
31source-repository this
32 type: git
33 location: git://github.com/cobit/krpc.git
34 branch: master
35 tag: v0.6.1.0
36
37flag builder
38 description: Use older bytestring package and bytestring-builder.
39 default: False
40
41flag aeson
42 description: Use aeson for pretty-printing bencoded data.
43 default: True
44
45library
46 default-language: Haskell2010
47 default-extensions: PatternGuards
48 , RecordWildCards
49 hs-source-dirs: src
50 exposed-modules: Network.KRPC
51 Network.KRPC.Message
52 Network.KRPC.Method
53 Network.KRPC.Manager
54 Data.BEncode.Pretty
55 build-depends: base == 4.*
56 , text >= 0.11
57 , data-default-class
58 , lifted-base >= 0.1.1
59 , transformers >= 0.2
60 , mtl
61 , monad-control >= 0.3
62 , monad-logger >= 0.3
63 , bencoding >= 0.4.3
64 , network >= 2.3
65 , cereal
66 , containers
67 if flag(aeson)
68 build-depends: aeson, aeson-pretty, unordered-containers, vector
69 ghc-options: -DBENCODE_AESON
70 if flag(builder)
71 build-depends: bytestring >= 0.9, bytestring-builder
72 else
73 build-depends: bytestring >= 0.10
74
75 if impl(ghc < 7.6)
76 build-depends: ghc-prim
77 ghc-options: -Wall
78
79test-suite spec
80 type: exitcode-stdio-1.0
81 default-language: Haskell2010
82 hs-source-dirs: tests
83 main-is: Spec.hs
84 other-modules: Network.KRPCSpec
85 Network.KRPC.MethodSpec
86 Network.KRPC.MessageSpec
87 build-depends: base == 4.*
88 , bytestring
89 , network
90 , mtl
91 , monad-logger
92 , hspec
93 , QuickCheck
94 , quickcheck-instances
95 , bencoding
96 , krpc
97
98benchmark bench
99 type: exitcode-stdio-1.0
100 default-language: Haskell2010
101 hs-source-dirs: bench
102 main-is: Main.hs
103 build-depends: base == 4.*
104 , bytestring
105 , mtl
106 , monad-logger
107 , criterion
108 , krpc
109 ghc-options: -O2 -fforce-recomp
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 @@
1{-# LANGUAGE CPP #-}
2module Data.BEncode.Pretty where -- (showBEncode) where
3
4import Data.BEncode.Types
5import qualified Data.ByteString as BS
6import qualified Data.ByteString.Lazy as BL
7import qualified Data.ByteString.Lazy.Char8 as BL8
8import Data.Text (Text)
9import qualified Data.Text as T
10#ifdef BENCODE_AESON
11import Data.BEncode.BDict hiding (map)
12import Data.Aeson.Types hiding (parse)
13import Data.Aeson.Encode.Pretty
14import qualified Data.HashMap.Strict as HashMap
15import qualified Data.Vector as Vector
16import Data.Foldable as Foldable
17import Data.Text.Encoding
18import Text.Printf
19#endif
20
21#ifdef BENCODE_AESON
22
23unhex :: Text -> BS.ByteString
24unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2]
25 where
26 nibs = encodeUtf8 t
27 unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10
28 + unnib (BS.index nibs (i * 2 + 1))
29 unnib a | a <= 0x39 = a - 0x30
30 | otherwise = a - (0x41 - 10)
31
32hex :: BS.ByteString -> Text
33hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs
34
35quote_chr :: Char
36quote_chr = ' '
37
38quote :: Text -> Text
39quote t = quote_chr `T.cons` t `T.snoc` quote_chr
40
41
42instance ToJSON BValue where
43 toJSON (BInteger x) = Number $ fromIntegral x
44 toJSON (BString s) = String $ either (const $ hex s) quote $ decodeUtf8' s
45 toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs
46 toJSON (BDict d) = toJSON d
47
48instance ToJSON a => ToJSON (BDictMap a) where
49 toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d
50 where
51 convert (k,v) = (decodeUtf8 k,toJSON v)
52
53instance FromJSON BValue where
54 parseJSON (Number x) = pure $ BInteger (truncate x)
55 parseJSON (Bool x) = pure $ BInteger $ if x then 1 else 0
56 parseJSON (String s)
57 | T.head s==quote_chr = pure $ BString $ encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s)
58 | otherwise = pure $ BString $ unhex s
59 parseJSON (Array v) = BList <$> traverse parseJSON (Foldable.toList v)
60 parseJSON (Object d) = BDict <$> parseJSON (Object d)
61 parseJSON (Null) = pure $ BDict Nil
62
63instance FromJSON v => FromJSON (BDictMap v) where
64 parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d)
65 where
66 convert (k,v) = (,) (encodeUtf8 k) <$> parseJSON v
67 parseJSON _ = fail "Not a BDict"
68#endif
69
70showBEncode :: BValue -> BL.ByteString
71#ifdef BENCODE_AESON
72showBEncode b = encodePretty $ toJSON b
73#else
74showBEncode b = BL8.pack (show b)
75#endif
diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs
new file mode 100644
index 00000000..d185fb4c
--- /dev/null
+++ b/src/Network/KRPC.hs
@@ -0,0 +1,91 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013, 2014
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- This module provides safe remote procedure call. One important
9-- point is exceptions and errors, so to be able handle them
10-- properly we need to investigate a bit about how this all works.
11-- Internally, in order to make method invokation KRPC makes the
12-- following steps:
13--
14-- * Caller serialize arguments to bencoded bytestrings;
15--
16-- * Caller send bytestring data over UDP to the callee;
17--
18-- * Callee receive and decode arguments to the method and method
19-- name. If it can't decode then it send 'ProtocolError' back to the
20-- caller;
21--
22-- * Callee search for the @method name@ in the method table.
23-- If it not present in the table then callee send 'MethodUnknown'
24-- back to the caller;
25--
26-- * Callee check if argument names match. If not it send
27-- 'ProtocolError' back;
28--
29-- * Callee make the actuall call to the plain old haskell
30-- function. If the function throw exception then callee send
31-- 'ServerError' back.
32--
33-- * Callee serialize result of the function to bencoded bytestring.
34--
35-- * Callee encode result to bencoded bytestring and send it back
36-- to the caller.
37--
38-- * Caller check if return values names match with the signature
39-- it called in the first step.
40--
41-- * Caller extracts results and finally return results of the
42-- procedure call as ordinary haskell values.
43--
44-- If every other error occurred then caller get the
45-- 'GenericError'. All errors returned by callee are throwed as
46-- ordinary haskell exceptions at caller side. Also note that both
47-- caller and callee use plain UDP, so KRPC is unreliable.
48--
49-- For async 'query' use @async@ package.
50--
51-- For protocol details see "Network.KRPC.Message" module.
52--
53module Network.KRPC
54 ( -- * Methods
55 Method
56 , KRPC (..)
57
58 -- * RPC
59 -- ** Query
60 , QueryFailure (..)
61 , query
62 , query'
63 , queryRaw
64 , getQueryCount
65
66 -- ** Handler
67 , HandlerFailure (..)
68 , Handler
69 , handler
70
71 -- * Manager
72 , MonadKRPC (..)
73 , Options (..)
74 , def
75 , Manager
76 , newManager
77 , closeManager
78 , withManager
79 , isActive
80 , listen
81
82 -- * Re-exports
83 , ErrorCode (..)
84 , SockAddr (..)
85 ) where
86
87import Data.Default.Class
88import Network.KRPC.Message
89import Network.KRPC.Method
90import Network.KRPC.Manager
91import Network.Socket (SockAddr (..))
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
new file mode 100644
index 00000000..c90c92f9
--- /dev/null
+++ b/src/Network/KRPC/Manager.hs
@@ -0,0 +1,485 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013, 2014
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- Normally, you don't need to import this module.
9--
10{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE FlexibleInstances #-}
12{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE DefaultSignatures #-}
15{-# LANGUAGE MultiParamTypeClasses #-}
16{-# LANGUAGE FunctionalDependencies #-}
17{-# LANGUAGE DeriveDataTypeable #-}
18{-# LANGUAGE TemplateHaskell #-}
19module Network.KRPC.Manager
20 ( -- * Manager
21 MonadKRPC (..)
22 , Options (..)
23 , Manager
24 , newManager
25 , closeManager
26 , withManager
27 , isActive
28 , listen
29
30 -- * Queries
31 , QueryFailure (..)
32 , query
33 , query'
34 , queryRaw
35 , getQueryCount
36
37 -- * Handlers
38 , HandlerFailure (..)
39 , Handler
40 , handler
41 ) where
42
43import Control.Applicative
44import Control.Concurrent
45import Control.Concurrent.Lifted (fork)
46import Control.Exception hiding (Handler)
47import qualified Control.Exception.Lifted as E (Handler (..))
48import Control.Exception.Lifted as Lifted (catches, finally)
49import Control.Monad
50import Control.Monad.Logger
51import Control.Monad.Reader
52import Control.Monad.Trans.Control
53import Data.BEncode as BE
54import Data.BEncode.Internal as BE
55import Data.BEncode.Pretty (showBEncode)
56import Data.ByteString as BS
57import Data.ByteString.Char8 as BC
58import Data.ByteString.Lazy as BL
59import Data.Default.Class
60import Data.IORef
61import Data.List as L
62import Data.Map as M
63import Data.Monoid
64import Data.Text as T
65import Data.Text.Encoding as T
66import Data.Tuple
67import Data.Typeable
68import Network.KRPC.Message
69import Network.KRPC.Method
70import Network.Socket hiding (listen)
71import Network.Socket.ByteString as BS
72import System.IO.Error
73import System.Timeout
74
75
76{-----------------------------------------------------------------------
77-- Options
78-----------------------------------------------------------------------}
79
80-- | RPC manager options.
81data Options = Options
82 { -- | Initial 'TransactionId' incremented with each 'query';
83 optSeedTransaction :: {-# UNPACK #-} !Int
84
85 -- | Time to wait for response from remote node, in seconds.
86 , optQueryTimeout :: {-# UNPACK #-} !Int
87
88 -- | Maximum number of bytes to receive.
89 , optMaxMsgSize :: {-# UNPACK #-} !Int
90 } deriving (Show, Eq)
91
92defaultSeedTransaction :: Int
93defaultSeedTransaction = 0
94
95defaultQueryTimeout :: Int
96defaultQueryTimeout = 120
97
98defaultMaxMsgSize :: Int
99defaultMaxMsgSize = 64 * 1024
100
101-- | Permissive defaults.
102instance Default Options where
103 def = Options
104 { optSeedTransaction = defaultSeedTransaction
105 , optQueryTimeout = defaultQueryTimeout
106 , optMaxMsgSize = defaultMaxMsgSize
107 }
108
109validateOptions :: Options -> IO ()
110validateOptions Options {..}
111 | optQueryTimeout < 1
112 = throwIO (userError "krpc: non-positive query timeout")
113 | optMaxMsgSize < 1
114 = throwIO (userError "krpc: non-positive buffer size")
115 | otherwise = return ()
116
117{-----------------------------------------------------------------------
118-- Options
119-----------------------------------------------------------------------}
120
121type KResult = Either KError KResponse
122
123type TransactionCounter = IORef Int
124type CallId = (TransactionId, SockAddr)
125type CallRes = MVar (BValue, KResult)
126type PendingCalls = IORef (Map CallId CallRes)
127
128type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue)
129
130-- | Handler is a function which will be invoked then some /remote/
131-- node querying /this/ node.
132type Handler h = (MethodName, HandlerBody h)
133
134-- | Keep track pending queries made by /this/ node and handle queries
135-- made by /remote/ nodes.
136data Manager h = Manager
137 { sock :: !Socket
138 , options :: !Options
139 , listenerThread :: !(MVar ThreadId)
140 , transactionCounter :: {-# UNPACK #-} !TransactionCounter
141 , pendingCalls :: {-# UNPACK #-} !PendingCalls
142 , handlers :: [Handler h]
143 }
144
145-- | A monad which can perform or handle queries.
146class (MonadBaseControl IO m, MonadLogger m, MonadIO m)
147 => MonadKRPC h m | m -> h where
148
149 -- | Ask for manager.
150 getManager :: m (Manager h)
151
152 default getManager :: MonadReader (Manager h) m => m (Manager h)
153 getManager = ask
154
155 -- | Can be used to add logging for instance.
156 liftHandler :: h a -> m a
157
158 default liftHandler :: m a -> m a
159 liftHandler = id
160
161instance (MonadBaseControl IO h, MonadLogger h, MonadIO h)
162 => MonadKRPC h (ReaderT (Manager h) h) where
163
164 liftHandler = lift
165
166sockAddrFamily :: SockAddr -> Family
167sockAddrFamily (SockAddrInet _ _ ) = AF_INET
168sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6
169sockAddrFamily (SockAddrUnix _ ) = AF_UNIX
170sockAddrFamily (SockAddrCan _ ) = AF_CAN
171
172-- | Bind socket to the specified address. To enable query handling
173-- run 'listen'.
174newManager :: Options -- ^ various protocol options;
175 -> SockAddr -- ^ address to listen on;
176 -> [Handler h] -- ^ handlers to run on incoming queries.
177 -> IO (Manager h) -- ^ new rpc manager.
178newManager opts @ Options {..} servAddr handlers = do
179 validateOptions opts
180 sock <- bindServ
181 tref <- newEmptyMVar
182 tran <- newIORef optSeedTransaction
183 calls <- newIORef M.empty
184 return $ Manager sock opts tref tran calls handlers
185 where
186 bindServ = do
187 let family = sockAddrFamily servAddr
188 sock <- socket family Datagram defaultProtocol
189 when (family == AF_INET6) $ do
190 setSocketOption sock IPv6Only 0
191 bindSocket sock servAddr
192 return sock
193
194-- | Unblock all pending calls and close socket.
195closeManager :: Manager m -> IO ()
196closeManager Manager {..} = do
197 maybe (return ()) killThread =<< tryTakeMVar listenerThread
198 -- TODO unblock calls
199 close sock
200
201-- | Check if the manager is still active. Manager becomes active
202-- until 'closeManager' called.
203isActive :: Manager m -> IO Bool
204isActive Manager {..} = liftIO $ isBound sock
205{-# INLINE isActive #-}
206
207-- | Normally you should use Control.Monad.Trans.Resource.allocate
208-- function.
209withManager :: Options -> SockAddr -> [Handler h]
210 -> (Manager h -> IO a) -> IO a
211withManager opts addr hs = bracket (newManager opts addr hs) closeManager
212
213{-----------------------------------------------------------------------
214-- Logging
215-----------------------------------------------------------------------}
216
217-- TODO prettify log messages
218querySignature :: MethodName -> TransactionId -> SockAddr -> Text
219querySignature name transaction addr = T.concat
220 [ "&", T.decodeUtf8 name
221 , " #", T.decodeUtf8 transaction
222 , " @", T.pack (show addr)
223 ]
224
225{-----------------------------------------------------------------------
226-- Client
227-----------------------------------------------------------------------}
228-- we don't need to know about TransactionId while performing query,
229-- so we introduce QueryFailure exceptions
230
231-- | Used to signal 'query' errors.
232data QueryFailure
233 = SendFailed -- ^ unable to send query;
234 | QueryFailed ErrorCode Text -- ^ remote node return error;
235 | TimeoutExpired -- ^ remote node not responding.
236 deriving (Show, Eq, Typeable)
237
238instance Exception QueryFailure
239
240sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m ()
241sendMessage sock addr a = do
242 liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr
243
244genTransactionId :: TransactionCounter -> IO TransactionId
245genTransactionId ref = do
246 cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur)
247 return $ BC.pack (show cur)
248
249-- | How many times 'query' call have been performed.
250getQueryCount :: MonadKRPC h m => m Int
251getQueryCount = do
252 Manager {..} <- getManager
253 curTrans <- liftIO $ readIORef transactionCounter
254 return $ curTrans - optSeedTransaction options
255
256registerQuery :: CallId -> PendingCalls -> IO CallRes
257registerQuery cid ref = do
258 ares <- newEmptyMVar
259 atomicModifyIORef' ref $ \ m -> (M.insert cid ares m, ())
260 return ares
261
262-- simultaneous M.lookup and M.delete guarantees that we never get two
263-- or more responses to the same query
264unregisterQuery :: CallId -> PendingCalls -> IO (Maybe CallRes)
265unregisterQuery cid ref = do
266 atomicModifyIORef' ref $ swap .
267 M.updateLookupWithKey (const (const Nothing)) cid
268
269
270-- (sendmsg EINVAL)
271sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO ()
272sendQuery sock addr q = handle sockError $ sendMessage sock addr q
273 where
274 sockError :: IOError -> IO ()
275 sockError _ = throwIO SendFailed
276
277-- | Enqueue query to the given node.
278--
279-- This function should throw 'QueryFailure' exception if quered node
280-- respond with @error@ message or the query timeout expires.
281--
282query :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m b
283query addr params = queryK addr params (\_ x _ -> x)
284
285-- | Like 'query' but possibly returns your externally routable IP address.
286query' :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, Maybe ReflectedIP)
287query' addr params = queryK addr params (const (,))
288
289-- | Enqueue a query, but give us the complete BEncoded content sent by the
290-- remote Node. This is useful for handling extensions that this library does
291-- not otherwise support.
292queryRaw :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, BValue)
293queryRaw addr params = queryK addr params (\raw x _ -> (x,raw))
294
295queryK :: forall h m a b x. (MonadKRPC h m, KRPC a b) =>
296 SockAddr -> a -> (BValue -> b -> Maybe ReflectedIP -> x) -> m x
297queryK addr params kont = do
298 Manager {..} <- getManager
299 tid <- liftIO $ genTransactionId transactionCounter
300 let queryMethod = method :: Method a b
301 let signature = querySignature (methodName queryMethod) tid addr
302 $(logDebugS) "query.sending" signature
303
304 mres <- liftIO $ do
305 ares <- registerQuery (tid, addr) pendingCalls
306
307 let q = KQuery (toBEncode params) (methodName queryMethod) tid
308 sendQuery sock addr q
309 `onException` unregisterQuery (tid, addr) pendingCalls
310
311 timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do
312 (raw,res) <- readMVar ares
313 case res of
314 Left (KError c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m)
315 Right (KResponse {..}) ->
316 case fromBEncode respVals of
317 Right r -> pure $ kont raw r respIP
318 Left e -> throwIO $ QueryFailed ProtocolError (T.pack e)
319
320 case mres of
321 Just res -> do
322 $(logDebugS) "query.responded" $ signature
323 return res
324
325 Nothing -> do
326 _ <- liftIO $ unregisterQuery (tid, addr) pendingCalls
327 $(logWarnS) "query.not_responding" $ signature <> " for " <>
328 T.pack (show (optQueryTimeout options)) <> " seconds"
329 throw $ TimeoutExpired
330
331{-----------------------------------------------------------------------
332-- Handlers
333-----------------------------------------------------------------------}
334-- we already throw:
335--
336-- * ErrorCode(MethodUnknown) in the 'dispatchHandler';
337--
338-- * ErrorCode(ServerError) in the 'runHandler';
339--
340-- * ErrorCode(GenericError) in the 'runHandler' (those can be
341-- async exception too)
342--
343-- so HandlerFailure should cover *only* 'ProtocolError's.
344
345-- | Used to signal protocol errors.
346data HandlerFailure
347 = BadAddress -- ^ for e.g.: node calls herself;
348 | InvalidParameter Text -- ^ for e.g.: bad session token.
349 deriving (Show, Eq, Typeable)
350
351instance Exception HandlerFailure
352
353prettyHF :: HandlerFailure -> BS.ByteString
354prettyHF BadAddress = T.encodeUtf8 "bad address"
355prettyHF (InvalidParameter reason) = T.encodeUtf8 $
356 "invalid parameter: " <> reason
357
358prettyQF :: QueryFailure -> BS.ByteString
359prettyQF e = T.encodeUtf8 $ "handler fail while performing query: "
360 <> T.pack (show e)
361
362-- | Make handler from handler function. Any thrown exception will be
363-- supressed and send over the wire back to the querying node.
364--
365-- If the handler make some 'query' normally it /should/ handle
366-- corresponding 'QueryFailure's.
367--
368handler :: forall h a b. (KRPC a b, Monad h)
369 => (SockAddr -> a -> h b) -> Handler h
370handler body = (name, wrapper)
371 where
372 Method name = method :: Method a b
373 wrapper addr args =
374 case fromBEncode args of
375 Left e -> return $ Left e
376 Right a -> do
377 r <- body addr a
378 return $ Right $ toBEncode r
379
380runHandler :: MonadKRPC h m
381 => HandlerBody h -> SockAddr -> KQuery -> m KResult
382runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks
383 where
384 signature = querySignature queryMethod queryId addr
385
386 wrapper = do
387 $(logDebugS) "handler.quered" signature
388 result <- liftHandler (h addr queryArgs)
389
390 case result of
391 Left msg -> do
392 $(logDebugS) "handler.bad_query" $ signature <> " !" <> T.pack msg
393 return $ Left $ KError ProtocolError (BC.pack msg) queryId
394
395 Right a -> do
396 $(logDebugS) "handler.success" signature
397 return $ Right $ KResponse a queryId (Just $ ReflectedIP addr)
398
399 failbacks =
400 [ E.Handler $ \ (e :: HandlerFailure) -> do
401 $(logDebugS) "handler.failed" signature
402 return $ Left $ KError ProtocolError (prettyHF e) queryId
403
404 -- may happen if handler makes query and fail
405 , E.Handler $ \ (e :: QueryFailure) -> do
406 return $ Left $ KError ServerError (prettyQF e) queryId
407
408 -- since handler thread exit after sendMessage we can safely
409 -- suppress async exception here
410 , E.Handler $ \ (e :: SomeException) -> do
411 return $ Left $ KError GenericError (BC.pack (show e)) queryId
412 ]
413
414dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult
415dispatchHandler q @ KQuery {..} addr = do
416 Manager {..} <- getManager
417 case L.lookup queryMethod handlers of
418 Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId
419 Just h -> runHandler h addr q
420
421{-----------------------------------------------------------------------
422-- Listener
423-----------------------------------------------------------------------}
424
425-- TODO bound amount of parallel handler *threads*:
426--
427-- peer A flooding with find_node
428-- peer B trying to ping peer C
429-- peer B fork too many threads
430-- ... space leak
431--
432handleQuery :: MonadKRPC h m => BValue -> KQuery -> SockAddr -> m ()
433handleQuery raw q addr = void $ fork $ do
434 Manager {..} <- getManager
435 res <- dispatchHandler q addr
436 let resbe = either toBEncode toBEncode res
437 $(logOther "q") $ T.unlines
438 [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw)
439 , "==>"
440 , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe)
441 ]
442 sendMessage sock addr resbe
443
444handleResponse :: MonadKRPC h m => BValue -> KResult -> SockAddr -> m ()
445handleResponse raw result addr = do
446 Manager {..} <- getManager
447 liftIO $ do
448 let resultId = either errorId respId result
449 mcall <- unregisterQuery (resultId, addr) pendingCalls
450 case mcall of
451 Nothing -> return ()
452 Just ares -> putMVar ares (raw,result)
453
454handleMessage :: MonadKRPC h m => BValue -> KMessage -> SockAddr -> m ()
455handleMessage raw (Q q) = handleQuery raw q
456handleMessage raw (R r) = handleResponse raw (Right r)
457handleMessage raw (E e) = handleResponse raw (Left e)
458
459listener :: MonadKRPC h m => m ()
460listener = do
461 Manager {..} <- getManager
462 forever $ do
463 (bs, addr) <- liftIO $ do
464 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
465
466 case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of
467 -- TODO ignore unknown messages at all?
468 Left e -> liftIO $ sendMessage sock addr $ unknownMessage e
469 Right (raw,m) -> handleMessage raw m addr
470 where
471 exceptions :: IOError -> IO (BS.ByteString, SockAddr)
472 exceptions e
473 -- packets with empty payload may trigger eof exception
474 | isEOFError e = return ("", SockAddrInet 0 0)
475 | otherwise = throwIO e
476
477-- | Should be run before any 'query', otherwise they will never
478-- succeed.
479listen :: MonadKRPC h m => m ()
480listen = do
481 Manager {..} <- getManager
482 tid <- fork $ do
483 listener `Lifted.finally`
484 liftIO (takeMVar listenerThread)
485 liftIO $ putMVar listenerThread tid
diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs
new file mode 100644
index 00000000..6f4ae620
--- /dev/null
+++ b/src/Network/KRPC/Message.hs
@@ -0,0 +1,289 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013, 2014
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- KRPC messages types used in communication. All messages are
9-- encoded as bencode dictionary.
10--
11-- Normally, you don't need to import this module.
12--
13-- See <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>
14--
15{-# LANGUAGE OverloadedStrings #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE TypeSynonymInstances #-}
18{-# LANGUAGE MultiParamTypeClasses #-}
19{-# LANGUAGE FunctionalDependencies #-}
20{-# LANGUAGE DefaultSignatures #-}
21{-# LANGUAGE DeriveDataTypeable #-}
22module Network.KRPC.Message
23 ( -- * Transaction
24 TransactionId
25
26 -- * Error
27 , ErrorCode (..)
28 , KError(..)
29 , decodeError
30 , unknownMessage
31
32 -- * Query
33 , KQuery(..)
34 , MethodName
35
36 -- * Response
37 , KResponse(..)
38 , ReflectedIP(..)
39
40 -- * Message
41 , KMessage (..)
42 ) where
43
44import Control.Applicative
45import Control.Arrow
46import Control.Exception.Lifted as Lifted
47import Data.BEncode as BE
48import Data.ByteString as B
49import Data.ByteString.Char8 as BC
50import qualified Data.Serialize as S
51import Data.Word
52import Data.Typeable
53import Network.Socket (SockAddr (..),PortNumber,HostAddress)
54
55
56-- | This transaction ID is generated by the querying node and is
57-- echoed in the response, so responses may be correlated with
58-- multiple queries to the same node. The transaction ID should be
59-- encoded as a short string of binary numbers, typically 2 characters
60-- are enough as they cover 2^16 outstanding queries.
61type TransactionId = ByteString
62
63unknownTransaction :: TransactionId
64unknownTransaction = ""
65
66{-----------------------------------------------------------------------
67-- Error messages
68-----------------------------------------------------------------------}
69
70-- | Types of RPC errors.
71data ErrorCode
72 -- | Some error doesn't fit in any other category.
73 = GenericError
74
75 -- | Occur when server fail to process procedure call.
76 | ServerError
77
78 -- | Malformed packet, invalid arguments or bad token.
79 | ProtocolError
80
81 -- | Occur when client trying to call method server don't know.
82 | MethodUnknown
83 deriving (Show, Read, Eq, Ord, Bounded, Typeable)
84
85-- | According to the table:
86-- <http://bittorrent.org/beps/bep_0005.html#errors>
87instance Enum ErrorCode where
88 fromEnum GenericError = 201
89 fromEnum ServerError = 202
90 fromEnum ProtocolError = 203
91 fromEnum MethodUnknown = 204
92 {-# INLINE fromEnum #-}
93
94 toEnum 201 = GenericError
95 toEnum 202 = ServerError
96 toEnum 203 = ProtocolError
97 toEnum 204 = MethodUnknown
98 toEnum _ = GenericError
99 {-# INLINE toEnum #-}
100
101instance BEncode ErrorCode where
102 toBEncode = toBEncode . fromEnum
103 {-# INLINE toBEncode #-}
104
105 fromBEncode b = toEnum <$> fromBEncode b
106 {-# INLINE fromBEncode #-}
107
108-- | Errors are sent when a query cannot be fulfilled. Error message
109-- can be send only from server to client but not in the opposite
110-- direction.
111--
112data KError = KError
113 { errorCode :: !ErrorCode -- ^ the type of error;
114 , errorMessage :: !ByteString -- ^ human-readable text message;
115 , errorId :: !TransactionId -- ^ match to the corresponding 'queryId'.
116 } deriving (Show, Read, Eq, Ord, Typeable)
117
118-- | Errors, or KRPC message dictionaries with a \"y\" value of \"e\",
119-- contain one additional key \"e\". The value of \"e\" is a
120-- list. The first element is an integer representing the error
121-- code. The second element is a string containing the error
122-- message.
123--
124-- Example Error Packet:
125--
126-- > { "t": "aa", "y":"e", "e":[201, "A Generic Error Ocurred"]}
127--
128-- or bencoded:
129--
130-- > d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee
131--
132instance BEncode KError where
133 toBEncode KError {..} = toDict $
134 "e" .=! (errorCode, errorMessage)
135 .: "t" .=! errorId
136 .: "y" .=! ("e" :: ByteString)
137 .: endDict
138 {-# INLINE toBEncode #-}
139
140 fromBEncode = fromDict $ do
141 lookAhead $ match "y" (BString "e")
142 (code, msg) <- field (req "e")
143 KError code msg <$>! "t"
144 {-# INLINE fromBEncode #-}
145
146instance Exception KError
147
148-- | Received 'queryArgs' or 'respVals' can not be decoded.
149decodeError :: String -> TransactionId -> KError
150decodeError msg = KError ProtocolError (BC.pack msg)
151
152-- | A remote node has send some 'KMessage' this node is unable to
153-- decode.
154unknownMessage :: String -> KError
155unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction
156
157{-----------------------------------------------------------------------
158-- Query messages
159-----------------------------------------------------------------------}
160
161type MethodName = ByteString
162
163-- | Query used to signal that caller want to make procedure call to
164-- callee and pass arguments in. Therefore query may be only sent from
165-- client to server but not in the opposite direction.
166--
167data KQuery = KQuery
168 { queryArgs :: !BValue -- ^ values to be passed to method;
169 , queryMethod :: !MethodName -- ^ method to call;
170 , queryId :: !TransactionId -- ^ one-time query token.
171 } deriving (Show, Read, Eq, Ord, Typeable)
172
173-- | Queries, or KRPC message dictionaries with a \"y\" value of
174-- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has
175-- a string value containing the method name of the query. Key \"a\"
176-- has a dictionary value containing named arguments to the query.
177--
178-- Example Query packet:
179--
180-- > { "t" : "aa", "y" : "q", "q" : "ping", "a" : { "msg" : "hi!" } }
181--
182instance BEncode KQuery where
183 toBEncode KQuery {..} = toDict $
184 "a" .=! queryArgs
185 .: "q" .=! queryMethod
186 .: "t" .=! queryId
187 .: "y" .=! ("q" :: ByteString)
188 .: endDict
189 {-# INLINE toBEncode #-}
190
191 fromBEncode = fromDict $ do
192 lookAhead $ match "y" (BString "q")
193 KQuery <$>! "a" <*>! "q" <*>! "t"
194 {-# INLINE fromBEncode #-}
195
196newtype ReflectedIP = ReflectedIP SockAddr
197 deriving (Eq, Ord, Show)
198
199instance BEncode ReflectedIP where
200 toBEncode (ReflectedIP addr) = BString (encodeAddr addr)
201 fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs
202 fromBEncode _ = Left "ReflectedIP should be a bencoded string"
203
204port16 :: Word16 -> PortNumber
205port16 = fromIntegral
206
207decodeAddr :: ByteString -> Either String SockAddr
208decodeAddr bs | B.length bs == 6
209 = ( \(a,p) -> SockAddrInet <$> fmap port16 p <*> a )
210 $ (S.runGet S.getWord32host *** S.decode )
211 $ B.splitAt 4 bs
212decodeAddr bs | B.length bs == 18
213 = ( \(a,p) -> flip SockAddrInet6 0 <$> fmap port16 p <*> a <*> pure 0 )
214 $ (S.decode *** S.decode )
215 $ B.splitAt 16 bs
216decodeAddr _ = Left "incorrectly sized address and port"
217
218encodeAddr :: SockAddr -> ByteString
219encodeAddr (SockAddrInet port addr)
220 = S.runPut (S.putWord32host addr >> S.put (fromIntegral port :: Word16))
221encodeAddr (SockAddrInet6 port _ addr _)
222 = S.runPut (S.put addr >> S.put (fromIntegral port :: Word16))
223encodeAddr _ = B.empty
224
225{-----------------------------------------------------------------------
226-- Response messages
227-----------------------------------------------------------------------}
228
229-- | Response messages are sent upon successful completion of a
230-- query:
231--
232-- * KResponse used to signal that callee successufully process a
233-- procedure call and to return values from procedure.
234--
235-- * KResponse should not be sent if error occurred during RPC,
236-- 'KError' should be sent instead.
237--
238-- * KResponse can be only sent from server to client.
239--
240data KResponse = KResponse
241 { respVals :: BValue -- ^ 'BDict' containing return values;
242 , respId :: TransactionId -- ^ match to the corresponding 'queryId'.
243 , respIP :: Maybe ReflectedIP
244 } deriving (Show, Eq, Ord, Typeable)
245
246-- | Responses, or KRPC message dictionaries with a \"y\" value of
247-- \"r\", contain one additional key \"r\". The value of \"r\" is a
248-- dictionary containing named return values.
249--
250-- Example Response packet:
251--
252-- > { "t" : "aa", "y" : "r", "r" : { "msg" : "you've sent: hi!" } }
253--
254instance BEncode KResponse where
255 toBEncode KResponse {..} = toDict $
256 "ip" .=? respIP
257 .: "r" .=! respVals
258 .: "t" .=! respId
259 .: "y" .=! ("r" :: ByteString)
260 .: endDict
261 {-# INLINE toBEncode #-}
262
263 fromBEncode = fromDict $ do
264 lookAhead $ match "y" (BString "r")
265 addr <- optional (field (req "ip"))
266 (\r t -> KResponse r t addr) <$>! "r" <*>! "t"
267 {-# INLINE fromBEncode #-}
268
269{-----------------------------------------------------------------------
270-- Summed messages
271-----------------------------------------------------------------------}
272
273-- | Generic KRPC message.
274data KMessage
275 = Q KQuery
276 | R KResponse
277 | E KError
278 deriving (Show, Eq)
279
280instance BEncode KMessage where
281 toBEncode (Q q) = toBEncode q
282 toBEncode (R r) = toBEncode r
283 toBEncode (E e) = toBEncode e
284
285 fromBEncode b =
286 Q <$> fromBEncode b
287 <|> R <$> fromBEncode b
288 <|> E <$> fromBEncode b
289 <|> decodingError "KMessage: unknown message or message tag"
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs
new file mode 100644
index 00000000..916b38a8
--- /dev/null
+++ b/src/Network/KRPC/Method.hs
@@ -0,0 +1,87 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013, 2014
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- Normally, you don't need to import this module.
9--
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE DefaultSignatures #-}
15module Network.KRPC.Method
16 ( Method (..)
17 , KRPC (..)
18 ) where
19
20import Data.BEncode (BEncode)
21import Data.ByteString.Char8 as BC
22import Data.Char
23import Data.Monoid
24import Data.List as L
25import Data.String
26import Data.Typeable
27import Network.KRPC.Message
28
29
30-- | Method datatype used to describe method name, parameters and
31-- return values of procedure. Client use a method to /invoke/, server
32-- /implements/ the method to make the actual work.
33--
34-- We use the following fantom types to ensure type-safiety:
35--
36-- * param: Type of method parameters.
37--
38-- * result: Type of return value of the method.
39--
40newtype Method param result = Method { methodName :: MethodName }
41 deriving (Eq, Ord, IsString, BEncode)
42
43-- | Example:
44--
45-- @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@
46--
47instance (Typeable a, Typeable b) => Show (Method a b) where
48 showsPrec _ = showsMethod
49
50showsMethod :: forall a b. ( Typeable a , Typeable b ) => Method a b -> ShowS
51showsMethod (Method name) =
52 showString (BC.unpack name) <>
53 showString " :: " <>
54 shows paramsTy <>
55 showString " -> " <>
56 shows valuesTy
57 where
58 impossible = error "KRPC.showsMethod: impossible"
59 paramsTy = typeOf (impossible :: a)
60 valuesTy = typeOf (impossible :: b)
61
62-- | In order to perform or handle KRPC query you need to provide
63-- corresponding 'KRPC' class.
64--
65-- Example:
66--
67-- @
68-- data Ping = Ping Text deriving BEncode
69-- data Pong = Pong Text deriving BEncode
70--
71-- instance 'KRPC' Ping Pong where
72-- method = \"ping\"
73-- @
74--
75class (Typeable req, BEncode req, Typeable resp, BEncode resp)
76 => KRPC req resp where
77
78 -- | Method name. Default implementation uses lowercased @req@
79 -- datatype name.
80 --
81 method :: Method req resp
82
83 -- TODO add underscores
84 default method :: Typeable req => Method req resp
85 method = Method $ fromString $ L.map toLower $ show $ typeOf hole
86 where
87 hole = error "krpc.method: impossible" :: req
diff --git a/tests/Network/KRPC/MessageSpec.hs b/tests/Network/KRPC/MessageSpec.hs
new file mode 100644
index 00000000..498ef679
--- /dev/null
+++ b/tests/Network/KRPC/MessageSpec.hs
@@ -0,0 +1,72 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.KRPC.MessageSpec (spec) where
4import Control.Applicative
5import Data.ByteString.Lazy as BL
6import Test.Hspec
7import Test.QuickCheck
8import Test.QuickCheck.Instances ()
9
10import Data.BEncode as BE
11import Network.KRPC.Message
12
13instance Arbitrary ErrorCode where
14 arbitrary = arbitraryBoundedEnum
15
16instance Arbitrary KError where
17 arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary
18
19instance Arbitrary KQuery where
20 arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary
21
22instance Arbitrary KResponse where
23 -- TODO: Abitrary instance for ReflectedIP
24 arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing
25
26instance Arbitrary KMessage where
27 arbitrary = frequency
28 [ (1, Q <$> arbitrary)
29 , (1, R <$> arbitrary)
30 , (1, E <$> arbitrary)
31 ]
32
33spec :: Spec
34spec = do
35 describe "error message" $ do
36 it "properly bencoded (iso)" $ property $ \ ke ->
37 BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError)
38
39 it "properly bencoded" $ do
40 BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee"
41 `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa")
42
43 BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee"
44 `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb")
45
46 BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee"
47 `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc")
48
49 BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee"
50 `shouldBe` Right
51 (KError MethodUnknown "Attempt to call unknown method" "dd")
52
53 describe "query message" $ do
54 it "properly bencoded (iso)" $ property $ \ kq ->
55 BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery)
56
57 it "properly bencoded" $ do
58 BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe`
59 Right (KQuery (BList []) "ping" "aa")
60
61
62 describe "response message" $ do
63 it "properly bencoded (iso)" $ property $ \ kr ->
64 BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse)
65
66 it "properly bencoded" $ do
67 BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe`
68 Right (KResponse (BList []) "aa" Nothing)
69
70 describe "generic message" $ do
71 it "properly bencoded (iso)" $ property $ \ km ->
72 BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage)
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 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Network.KRPC.MethodSpec where
8import Control.Applicative
9import Data.BEncode
10import Data.ByteString as BS
11import Data.Typeable
12import Network.KRPC
13import Test.Hspec
14
15
16data Ping = Ping
17 deriving (Show, Eq, Typeable)
18
19instance BEncode Ping where
20 toBEncode Ping = toBEncode ()
21 fromBEncode b = Ping <$ (fromBEncode b :: Result ())
22
23instance KRPC Ping Ping
24
25ping :: Monad h => Handler h
26ping = handler $ \ _ Ping -> return Ping
27
28newtype Echo a = Echo a
29 deriving (Show, Eq, BEncode, Typeable)
30
31echo :: Monad h => Handler h
32echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString))
33
34instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a)
35
36spec :: Spec
37spec = do
38 describe "ping method" $ do
39 it "name is ping" $ do
40 (method :: Method Ping Ping) `shouldBe` "ping"
41
42 it "has pretty Show instance" $ do
43 show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping"
44
45 describe "echo method" $ do
46 it "is overloadable" $ do
47 (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int"
48 (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool"
49
50 it "has pretty Show instance" $ do
51 show (method :: Method (Echo Int) (Echo Int))
52 `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..eabcc817
--- /dev/null
+++ b/tests/Network/KRPCSpec.hs
@@ -0,0 +1,59 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.KRPCSpec (spec) where
4import Control.Monad.Logger
5import Control.Monad.Reader
6import Network.KRPC
7import Network.KRPC.MethodSpec hiding (spec)
8import Test.Hspec
9
10servAddr :: SockAddr
11servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127)
12
13handlers :: [Handler IO]
14handlers =
15 [ handler $ \ _ Ping -> return Ping
16 , handler $ \ _ (Echo a) -> return (Echo (a :: Bool))
17 , handler $ \ _ (Echo a) -> return (Echo (a :: Int))
18 ]
19
20instance MonadLogger IO where
21 monadLoggerLog _ _ _ _ = return ()
22
23opts :: Options
24opts = def { optQueryTimeout = 1 }
25
26spec :: Spec
27spec = do
28 let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int)
29 qr = query
30
31 describe "manager" $ do
32 it "is active until closeManager called" $ do
33 m <- newManager opts servAddr []
34 isActive m `shouldReturn` True
35 closeManager m
36 isActive m `shouldReturn` False
37
38 describe "query" $ do
39 it "run handlers" $ do
40 let int = 0xabcd :: Int
41 (withManager opts servAddr handlers $ runReaderT $ do
42 listen
43 query servAddr (Echo int))
44 `shouldReturn` Echo int
45
46 it "count transactions properly" $ do
47 (withManager opts servAddr handlers $ runReaderT $ do
48 listen
49 _ <- qr servAddr (Echo 0xabcd)
50 _ <- qr servAddr (Echo 0xabcd)
51 getQueryCount
52 )
53 `shouldReturn` 2
54
55 it "throw timeout exception" $ do
56 (withManager opts servAddr handlers $ runReaderT $ do
57 qr servAddr (Echo 0xabcd)
58 )
59 `shouldThrow` (== TimeoutExpired)