1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
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 #-}
|
