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
|
-- |
-- Copyright : (c) Sam Truzjan 2013
-- License : BSD
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- This module provides unified RPC interface to BitTorrent
-- trackers. The tracker is an UDP/HTTP/HTTPS service used to
-- discovery peers for a particular existing torrent and keep
-- statistics about the swarm. This module also provides a way to
-- request scrape info for a particular torrent list.
--
{-# LANGUAGE DeriveDataTypeable #-}
module Network.BitTorrent.Tracker.RPC
( PeerInfo (..)
-- * Manager
, Options (..)
, Manager
, newManager
, closeManager
, withManager
-- * RPC
, SAnnounceQuery (..)
, RpcException (..)
, Network.BitTorrent.Tracker.RPC.announce
, scrape
) where
import Control.Exception
import Data.Default
import Data.Typeable
import Network
import Network.URI
import Network.Socket (HostAddress)
import Data.Torrent
import Data.Torrent.Progress
import Network.BitTorrent.Core
import Network.BitTorrent.Tracker.Message
import qualified Network.BitTorrent.Tracker.RPC.HTTP as HTTP
import qualified Network.BitTorrent.Tracker.RPC.UDP as UDP
{-----------------------------------------------------------------------
-- Simplified announce
-----------------------------------------------------------------------}
-- | Info to advertise to trackers.
data PeerInfo = PeerInfo
{ peerId :: !PeerId
, peerIP :: !(Maybe HostAddress)
, peerPort :: !PortNumber
} deriving (Show, Eq)
instance Default PeerInfo where
def = PeerInfo def Nothing 6881
-- | Simplified announce query.
data SAnnounceQuery = SAnnounceQuery
{ sInfoHash :: InfoHash
, sProgress :: Progress
, sNumWant :: Maybe Int
, sEvent :: Maybe AnnounceEvent
}
fillAnnounceQuery :: PeerInfo -> SAnnounceQuery -> AnnounceQuery
fillAnnounceQuery PeerInfo{..} SAnnounceQuery {..} = AnnounceQuery
{ reqInfoHash = sInfoHash
, reqPeerId = peerId
, reqPort = peerPort
, reqProgress = sProgress
, reqIP = peerIP
, reqNumWant = sNumWant
, reqEvent = sEvent
}
{-----------------------------------------------------------------------
-- RPC manager
-----------------------------------------------------------------------}
-- | Tracker manager settings.
data Options = Options
{ -- | HTTP tracker protocol specific options.
optHttpRPC :: !HTTP.Options
-- | UDP tracker protocol specific options.
, optUdpRPC :: !UDP.Options
-- | Whether to use multitracker extension.
, optMultitracker :: !Bool
}
instance Default Options where
def = Options
{ optHttpRPC = def
, optUdpRPC = def
, optMultitracker = True
}
-- | Tracker RPC Manager.
data Manager = Manager
{ options :: !Options
, peerInfo :: !PeerInfo
, httpMgr :: !HTTP.Manager
, udpMgr :: !UDP.Manager
}
-- | Create a new 'Manager'. You /must/ manually 'closeManager'
-- otherwise resource leakage is possible. Normally, a bittorrent
-- client need a single RPC manager only.
--
-- This function can throw 'IOException' on invalid 'Options'.
--
newManager :: Options -> PeerInfo -> IO Manager
newManager opts info = do
h <- HTTP.newManager (optHttpRPC opts)
u <- UDP.newManager (optUdpRPC opts) `onException` HTTP.closeManager h
return $ Manager opts info h u
-- | Close all pending RPCs. Behaviour of currently in-flight RPCs can
-- differ depending on underlying protocol used. No rpc calls should
-- be performed after manager becomes closed.
closeManager :: Manager -> IO ()
closeManager Manager {..} = do
UDP.closeManager udpMgr `finally` HTTP.closeManager httpMgr
-- | Normally you need to use 'Control.Monad.Trans.Resource.allocate'.
withManager :: Options -> PeerInfo -> (Manager -> IO a) -> IO a
withManager opts info = bracket (newManager opts info) closeManager
{-----------------------------------------------------------------------
-- Exceptions
-----------------------------------------------------------------------}
-- TODO Catch IO exceptions on rpc calls (?)
data RpcException
= UdpException UDP.RpcException -- ^ UDP RPC driver failure;
| HttpException HTTP.RpcException -- ^ HTTP RPC driver failure;
| UnrecognizedScheme String -- ^ unsupported scheme in announce URI;
| GenericException String -- ^ for furter extensibility.
deriving (Show, Typeable)
instance Exception RpcException
packException :: Exception e => (e -> RpcException) -> IO a -> IO a
packException f m = try m >>= either (throwIO . f) return
{-# INLINE packException #-}
{-----------------------------------------------------------------------
-- RPC calls
-----------------------------------------------------------------------}
dispatch :: URI -> IO a -> IO a -> IO a
dispatch URI {..} http udp
| uriScheme == "http:" ||
uriScheme == "https:" = packException HttpException http
| uriScheme == "udp:" = packException UdpException udp
| otherwise = throwIO $ UnrecognizedScheme uriScheme
announce :: Manager -> URI -> SAnnounceQuery -> IO AnnounceInfo
announce Manager {..} uri simpleQuery
= dispatch uri
(HTTP.announce httpMgr uri annQ)
( UDP.announce udpMgr uri annQ)
where
annQ = fillAnnounceQuery peerInfo simpleQuery
scrape :: Manager -> URI -> ScrapeQuery -> IO ScrapeInfo
scrape Manager {..} uri q
= dispatch uri
(HTTP.scrape httpMgr uri q)
( UDP.scrape udpMgr uri q)
|
