diff options
Diffstat (limited to 'src/Network/Torrent/Tracker.hs')
-rw-r--r-- | src/Network/Torrent/Tracker.hs | 208 |
1 files changed, 208 insertions, 0 deletions
diff --git a/src/Network/Torrent/Tracker.hs b/src/Network/Torrent/Tracker.hs new file mode 100644 index 00000000..72fbcb44 --- /dev/null +++ b/src/Network/Torrent/Tracker.hs | |||
@@ -0,0 +1,208 @@ | |||
1 | {-# OPTIONS -fno-warn-orphans #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | module Network.Torrent.Tracker | ||
4 | ( module Network.Torrent.Tracker.Scrape | ||
5 | , Peer(..), Event(..), TRequest(..), TResponse(..) | ||
6 | , defaultRequest, defaultPorts | ||
7 | , sendRequest | ||
8 | ) | ||
9 | where | ||
10 | |||
11 | import Network.Torrent.Tracker.Scrape | ||
12 | |||
13 | import Control.Applicative | ||
14 | import Data.Char as Char | ||
15 | import Data.Word (Word32) | ||
16 | import Data.List as L | ||
17 | import Data.Map as M | ||
18 | import Data.Monoid | ||
19 | import Data.BEncode | ||
20 | import Data.ByteString as B | ||
21 | import Data.ByteString.Char8 as BC | ||
22 | import Data.Text as T | ||
23 | import Data.Serialize.Get hiding (Result) | ||
24 | import Data.URLEncoded as URL | ||
25 | |||
26 | import Network | ||
27 | import Network.Socket | ||
28 | import Network.HTTP | ||
29 | import Network.URI | ||
30 | import Network.Torrent.PeerID | ||
31 | |||
32 | import Numeric | ||
33 | |||
34 | type Hash = ByteString | ||
35 | |||
36 | data Peer = Peer { | ||
37 | peerID :: Maybe PeerID | ||
38 | , peerIP :: HostAddress | ||
39 | , peerPort :: PortNumber | ||
40 | } deriving Show | ||
41 | |||
42 | data Event = Started -- ^ For first request. | ||
43 | | Stopped -- ^ Sent when the peer is shutting down. | ||
44 | | Completed -- ^ To be sent when the peer completes a download. | ||
45 | deriving (Show, Read, Eq, Ord, Enum, Bounded) | ||
46 | |||
47 | data TRequest = TRequest { -- TODO peer here -- TODO detach announce | ||
48 | reqAnnounce :: URI -- ^ Announce url of the torrent. | ||
49 | , reqInfoHash :: Hash -- ^ Hash of info part of the torrent. | ||
50 | , reqPeerID :: PeerID -- ^ Id of the peer doing request. () | ||
51 | , reqPort :: PortNumber -- ^ Port to listen to for connection from other peers. | ||
52 | , reqUploaded :: Int -- ^ # of bytes that the peer has uploaded in the swarm. | ||
53 | , reqDownloaded :: Int -- ^ # of bytes downloaded in the swarm by the peer. | ||
54 | , reqLeft :: Int -- ^ # of bytes needed in order to complete download. | ||
55 | , reqIP :: Maybe HostAddress -- ^ The peer IP. | ||
56 | , reqNumWant :: Maybe Int -- ^ Number of peers that the peers wants to receive from. | ||
57 | , reqEvent :: Maybe Event -- ^ If not specified, | ||
58 | -- the request is regular periodic request. | ||
59 | } deriving Show | ||
60 | |||
61 | data TResponse = | ||
62 | Failure Text -- ^ Failure reason in human readable form. | ||
63 | | OK { | ||
64 | respWarning :: Maybe Text | ||
65 | , respInterval :: Int -- ^ Recommended interval to wait between requests. | ||
66 | , respMinInterval :: Maybe Int -- ^ Minimal amount of time between requests. | ||
67 | , respComplete :: Maybe Int -- ^ Number of peers completed the torrent. (seeders) | ||
68 | , respIncomplete :: Maybe Int -- ^ Number of peers downloading the torrent. | ||
69 | , respPeers :: [Peer] -- ^ Peers that must be contacted. | ||
70 | } deriving Show | ||
71 | |||
72 | instance BEncodable PortNumber where | ||
73 | toBEncode = toBEncode . fromEnum | ||
74 | fromBEncode b = toEnum <$> fromBEncode b | ||
75 | |||
76 | instance BEncodable Peer where | ||
77 | toBEncode (Peer pid pip pport) = fromAssocs | ||
78 | [ "peer id" -->? pid | ||
79 | , "ip" --> pip | ||
80 | , "port" --> pport | ||
81 | ] | ||
82 | |||
83 | fromBEncode (BDict d) = | ||
84 | Peer <$> d >--? "peer id" | ||
85 | <*> d >-- "ip" | ||
86 | <*> d >-- "port" | ||
87 | |||
88 | fromBEncode _ = decodingError "Peer" | ||
89 | |||
90 | instance BEncodable TResponse where | ||
91 | toBEncode (Failure t) = fromAssocs ["failure reason" --> t] | ||
92 | toBEncode resp@(OK {}) = fromAssocs | ||
93 | [ "interval" --> respInterval resp | ||
94 | , "min interval" -->? respMinInterval resp | ||
95 | , "complete" -->? respComplete resp | ||
96 | , "incomplete" -->? respIncomplete resp | ||
97 | , "peers" --> respPeers resp | ||
98 | ] | ||
99 | |||
100 | fromBEncode (BDict d) | ||
101 | | Just t <- M.lookup "failure reason" d = Failure <$> fromBEncode t | ||
102 | | otherwise = OK <$> d >--? "warning message" | ||
103 | <*> d >-- "interval" | ||
104 | <*> d >--? "min interval" | ||
105 | <*> d >--? "complete" | ||
106 | <*> d >--? "incomplete" | ||
107 | <*> getPeers (M.lookup "peers" d) | ||
108 | |||
109 | where | ||
110 | getPeers :: Maybe BEncode -> Result [Peer] | ||
111 | getPeers (Just (BList l)) = fromBEncode (BList l) | ||
112 | getPeers (Just (BString s)) | ||
113 | | B.length s `mod` 6 == 0 = | ||
114 | let cnt = B.length s `div` 6 in | ||
115 | runGet (sequence (L.replicate cnt peerG)) s | ||
116 | | otherwise = decodingError "peers length not a multiple of 6" | ||
117 | where | ||
118 | peerG = do | ||
119 | pip <- getWord32be | ||
120 | pport <- getWord16be | ||
121 | return (Peer Nothing (fromIntegral pip) (fromIntegral pport)) | ||
122 | |||
123 | getPeers _ = decodingError "Peers" | ||
124 | |||
125 | fromBEncode _ = decodingError "TResponse" | ||
126 | |||
127 | |||
128 | instance URLShow PortNumber where | ||
129 | urlShow = urlShow . fromEnum | ||
130 | |||
131 | instance URLShow PeerID where | ||
132 | urlShow = BC.unpack . getPeerID | ||
133 | |||
134 | instance URLShow Word32 where | ||
135 | urlShow = show | ||
136 | |||
137 | instance URLShow Event where | ||
138 | urlShow e = urlShow (Char.toLower x : xs) | ||
139 | where | ||
140 | -- this is always nonempty list | ||
141 | (x : xs) = show e | ||
142 | |||
143 | instance URLEncode TRequest where | ||
144 | urlEncode req = mconcat | ||
145 | [ s "peer_id" %= reqPeerID req | ||
146 | , s "port" %= reqPort req | ||
147 | , s "uploaded" %= reqUploaded req | ||
148 | , s "downloaded" %= reqDownloaded req | ||
149 | , s "left" %= reqLeft req | ||
150 | , s "ip" %=? reqIP req | ||
151 | , s "numwant" %=? reqNumWant req | ||
152 | , s "event" %=? reqEvent req | ||
153 | ] | ||
154 | where s :: String -> String; s = id; {-# INLINE s #-} | ||
155 | |||
156 | encodeRequest :: TRequest -> URI | ||
157 | encodeRequest req = URL.urlEncode req `addToURI` reqAnnounce req | ||
158 | `addHash` BC.unpack (reqInfoHash req) | ||
159 | where | ||
160 | addHash :: URI -> String -> URI | ||
161 | addHash uri s = uri { uriQuery = uriQuery uri ++ "&info_hash=" ++ rfc1738Encode s } | ||
162 | |||
163 | rfc1738Encode :: String -> String | ||
164 | rfc1738Encode = L.concatMap (\c -> if unreserved c then [c] else encode c) | ||
165 | where | ||
166 | unreserved = (`L.elem` chars) | ||
167 | chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_./" | ||
168 | encode :: Char -> String | ||
169 | encode c = '%' : pHex c | ||
170 | pHex c = | ||
171 | let p = (showHex . ord $ c) "" | ||
172 | in if L.length p == 1 then '0' : p else p | ||
173 | |||
174 | |||
175 | -- | Ports typically reserved for bittorrent. | ||
176 | defaultPorts :: [PortNumber] | ||
177 | defaultPorts = [6881..6889] | ||
178 | |||
179 | defaultRequest :: URI -> Hash -> PeerID -> TRequest | ||
180 | defaultRequest announce hash pid = | ||
181 | TRequest { | ||
182 | reqAnnounce = announce | ||
183 | , reqInfoHash = hash | ||
184 | , reqPeerID = pid | ||
185 | , reqPort = L.head defaultPorts | ||
186 | , reqUploaded = 0 | ||
187 | , reqDownloaded = 0 | ||
188 | , reqLeft = 0 | ||
189 | , reqIP = Nothing | ||
190 | , reqNumWant = Just 25 | ||
191 | , reqEvent = Just Started | ||
192 | } | ||
193 | |||
194 | -- | TODO rename to ask for peers | ||
195 | -- | ||
196 | sendRequest :: TRequest -> IO (Result TResponse) | ||
197 | sendRequest req = do | ||
198 | let r = mkHTTPRequest (encodeRequest req) | ||
199 | print r | ||
200 | |||
201 | rawResp <- simpleHTTP r | ||
202 | respBody <- getResponseBody rawResp | ||
203 | print respBody | ||
204 | return (decoded (BC.pack respBody)) | ||
205 | |||
206 | where | ||
207 | mkHTTPRequest :: URI -> Request String | ||
208 | mkHTTPRequest uri = Request uri GET [] "" | ||